Объединение книг и листов по имени листа

[K_Auditor]

Всем привет. По долгу работы столкнулся с ситуацией, когда нужно переносить данные с разных книг в один файл для последующей обработки. На форуме просмотрел темы, но именно того что мне нужно не нашел, а необходимо следующее:

Постановка задачи: Имеется ряд файлов в одной папке с различным расширением ( *.xls и *.xlsx) Большинство файлов имеют одинаковую структуру, в том числе названия листов. Необходимо скопировать все листы с указанным именем в одну книгу, причем скопированные листы переименовать в соответствии с именем исходного файла из которого они были вытянуты.

Прошерстив частично форум нашел хороший макрос, но он не совсем мне подходит, т.к. вытягивает данные с разных листов в один. Вот он:

Option Explicit

Sub Consolidated_Range_of_Books_and_She ets()
Dim iPivotRange As Range, iDestinationRange As Range, iBeginRange As Range, Sheet
Dim iRngAddress As String, oAwb As String, DataSheet As String, _
iCopyAddress As String, sSheetName As String, oFile
Dim lLastrow As Long, lLastRowMyBook As Long
Dim iLastColumn As Integer
Dim Str() As String

ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
DataSheet = ThisWorkbook.ActiveSheet.Name
On Error Resume Next
Set iBeginRange = Application.InputBox("Выберите диапазон сбора данных." & vbCrLf & _
"1. При выборе только одной ячейки данные будут собраны со всех листов начиная с этой ячейки. " & _
vbCrLf & "2. При выделении нескольких ячеек данные будут собраны только с указанного диапазона всех листов.", Type:=8)
If iBeginRange Is Nothing Then Exit Sub
sSheetName = InputBox("Введите имя листа, с которого собирать данные(если не указан, то данные собираются со всех листов)", "Параметр")
If sSheetName = "" Then sSheetName = "*"
On Error GoTo 0
With Application.FileDialog(msoFileDialo gFilePicker)
.AllowMultiSelect = True
.InitialFileName = "*.*"
.Title = "Выберите файлы"
If .Show = False Then Exit Sub
For Each oFile In .SelectedItems
Workbooks.OpenText Filename:=oFile
oAwb = Dir(oFile, vbDirectory)

Application.ScreenUpdating = False
Workbooks(oAwb).Activate
For Each Sheet In Sheets
If Sheet.Name Like sSheetName Then
Sheet.Activate
Select Case iBeginRange.Count
Case 1
lLastrow = Cells(1, 1).SpecialCells(xlLastCell).Row
iLastColumn = Cells.SpecialCells(xlLastCell).Colu mn
iCopyAddress = Range(Cells(iBeginRange.Row, iBeginRange.Column), Cells(lLastrow, iLastColumn)).Address
Case Else
iCopyAddress = iBeginRange.Address
lLastrow = iBeginRange.Rows.Count
iLastColumn = iBeginRange.Columns.Count
End Select
lLastRowMyBook = ThisWorkbook.Sheets(DataSheet).Cell s.SpecialCells(xlLastCell).Row + 1
iRngAddress = Range(Cells(lLastRowMyBook, 1), Cells(lLastRowMyBook + lLastrow, iLastColumn)).Address
Sheet.Range(iCopyAddress).Copy Destination:=ThisWorkbook.Sheets(Da taSheet).Range(iRngAddress)
End If
Next Sheet
Workbooks(oAwb).Close False
Next oFile
End With
Application.ScreenUpdating = True
End Sub

Скорее всего кто-то уже решал такую задачу. Просьба поделиться макросом)

[ikki_pf]

Сообщение от K_Auditor

Скорее всего кто-то уже решал такую задачу. Просьба поделиться макросом)

Вы сознательно ограничили круг помогающих?
а если "кто-то" не решал, но может решить?

[The_Prist]

попробуйте такой код:

Sub Consolidated_Sheets_to_One_Book()
    Dim wsSh As Worksheet, oAwb As String, sSheetName As String, oFile

    sSheetName = InputBox("Введите имя листа, с которого собирать данные(если не указан, то данные собираются со всех листов)", "Параметр")
    If sSheetName = "" Then sSheetName = "*"
    On Error GoTo 0
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .InitialFileName = "*.*"
        .Title = "Выберите файлы"
        If .Show = False Then Exit Sub
        For Each oFile In .SelectedItems
            Workbooks.Open Filename:=oFile
            oAwb = Dir(oFile, vbDirectory)
            Application.ScreenUpdating = False
            Workbooks(oAwb).Activate
            For Each wsSh In Sheets
                If wsSh.Name Like sSheetName Then
                    wsSh.Copy ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Mid$(oAwb, 1, InStr(oAwb, ".") - 1)
                End If
            Next wsSh
            Workbooks(oAwb).Close False
        Next oFile
    End With
    Application.ScreenUpdating = True
End Sub

сам не тестировал, так что пробуйте.

[K_Auditor]

Сообщение от ikki_pf

Вы сознательно ограничили круг помогающих?
а если "кто-то" не решал, но может решить?

Да нет, даже если кто-то не решал, но у него есть желание помочь, то пожалуйста)

[K_Auditor]

Сообщение от The_Prist

попробуйте такой код:

Sub Consolidated_Sheets_to_One_Book()
    Dim wsSh As Worksheet, oAwb As String, sSheetName As String, oFile

    sSheetName = InputBox("Введите имя листа, с которого собирать данные(если не указан, то данные собираются со всех листов)", "Параметр")
    If sSheetName = "" Then sSheetName = "*"
    On Error GoTo 0
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .InitialFileName = "*.*"
        .Title = "Выберите файлы"
        If .Show = False Then Exit Sub
        For Each oFile In .SelectedItems
            Workbooks.Open Filename:=oFile
            oAwb = Dir(oFile, vbDirectory)
            Application.ScreenUpdating = False
            Workbooks(oAwb).Activate
            For Each wsSh In Sheets
                If wsSh.Name Like sSheetName Then
                    wsSh.Copy ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Mid$(oAwb, 1, InStr(oAwb, ".") - 1)
                End If
            Next wsSh
            Workbooks(oAwb).Close False
        Next oFile
    End With
    Application.ScreenUpdating = True
End Sub

сам не тестировал, так что пробуйте.

Нет, это немного не то, он вытягивает все листы, не переименовывая их, а мне нужно только определенные, с последующими переименованием в название файла из которого они вытянуты. Но все равно спс

[The_Prist]

Сообщение от K_Auditor

Нет, это немного не то, он вытягивает все листы, не переименовывая их, а мне нужно только определенные, с последующими переименованием в название файла из которого они вытянуты. Но все равно спс

Макрос делает то, что надо: спрашивет имя листа в книгах, который надо копировать и затем дает возможность выбрать файлы с этими листами. Единственное, необходимо запятую поставить(забыл), чтобы переименовывал нужные листы:

wsSh.Copy ,ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

[K_Auditor]

Сообщение от The_Prist

Макрос делает то, что надо: спрашивет имя листа в книгах, который надо копировать и затем дает возможность выбрать файлы с этими листами. Единственное, необходимо запятую поставить(забыл), чтобы переименовывал нужные листы:

wsSh.Copy ,ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

Действительно, спасибо за содействие, очень помогли мне). Еще просьба, посоветуйте либо ресурс либо книгу по которой с нуля можно начать осваивать программирование в excel. Хочу в коде разобраться

[The_Prist]

Сообщение от K_Auditor

Действительно, спасибо за содействие, очень помогли мне). Еще просьба, посоветуйте либо ресурс либо книгу по которой с нуля можно начать осваивать программирование в excel. Хочу в коде разобраться

Мой сайт в подписи, раздел Что умеет Excel. Там можно найти статьи по основам программирования в Excel. Так же на сайте есть книги. Еще загляните на PlanetaExcel.ru - там много полезных статей. Чаще общайтесь на форумах, решая задачи, как свои так и чужие. Так быстрее всего научитесь.

[K_Auditor]

Сообщение от The_Prist

Макрос делает то, что надо: спрашивет имя листа в книгах, который надо копировать и затем дает возможность выбрать файлы с этими листами. Единственное, необходимо запятую поставить(забыл), чтобы переименовывал нужные листы:

wsSh.Copy ,ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

Спасибо за пояснение, на простых листах все работает хорошо, но я столкнулся с проблемой (по крайней мере я так ее понял), что если в ячейке есть ссылка в которую нельзя провалиться (например файл скопирован с другого компа без файла на который идет ссылка, при этом число эксель запоминает) то выскакивает ошибка и макрос дальше не работает) Можно ли что-нить добавить чтобы этого не происходило?

[The_Prist]

Сообщение от K_Auditor

если в ячейке есть ссылка.....
Можно ли что-нить добавить чтобы этого не происходило?

Можно ли хоть как-то увидеть куда Вы "провалиться" не можете?