Sub CollectFiles()
Dim aFiles As Variant
aFiles = ShowFileDialog()
If IsEmpty(aFiles) Then Exit Sub
Dim wb1 As Workbook
Set wb1 = Workbooks.Add(1)
Dim wb2 As Workbook
Dim vFile As Variant
For Each vFile In aFiles
Set wb2 = Workbooks.Open(vFile, False, True)
CopyWb wb1, wb2
wb2.Close False
Next
wb1.Saved = True
End Sub
Private Sub CopyWb(wb1 As Workbook, wb2 As Workbook)
Dim sh1 As Worksheet
Dim sh2 As Worksheet
For Each sh2 In wb2.Worksheets
If sh2.Visible = xlSheetVisible Then
Select Case sh2.Name
Case "Инструкция"
Case Else
On Error Resume Next
Set sh1 = wb1.Worksheets(sh2.Name)
On Error GoTo 0
If sh1 Is Nothing Then
sh2.Copy After:=wb1.Worksheets(wb1.Worksheets.Count)
Else
CopySheets sh1, sh2
End If
Set sh1 = Nothing
End Select
End If
Next
End Sub
Private Sub CopySheets(sh1 As Worksheet, sh2 As Worksheet)
Dim arrCopy As Variant
Dim x2 As Long
Dim x1 As Long
Dim y2 As Long
Dim y1 As Long
With sh1
y1 = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
y2 = sh2.UsedRange.Rows.Count
For x2 = 1 To sh2.UsedRange.Columns.Count
If Not IsEmpty(sh2.Cells(2, x2).Value) Then
x1 = 0
On Error Resume Next
x1 = WorksheetFunction.Match(sh2.Cells(2, x2).Value, sh1.Rows(2), 0)
On Error GoTo 0
If x1 = 0 Then x1 = sh1.UsedRange.Columns.Count + 1
With sh2
If y2 = 4 Then
ReDim arrCopy(1 To 1, 1 To 1)
arrCopy(1, 1) = .Cells(y2, x2).Value
Else
arrCopy = .Range(.Cells(4, x2), .Cells(y2, x2))
End If
End With
sh1.Cells(y1, x1).Resize(UBound(arrCopy, 1), UBound(arrCopy, 2)) = arrCopy
End If
Next
End Sub
Private Function ShowFileDialog() As Variant
Dim oFD As FileDialog
Dim x, lf As Long
'назначаем переменной ссылку на экземпляр диалога
Set oFD = Application.FileDialog(msoFileDialogFilePicker)
With oFD 'используем короткое обращение к объекту
'так же можно без oFD
'With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Title = "Выбрать файлы" 'заголовок окна диалога
.Filters.Clear 'очищаем установленные ранее типы файлов
.Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
'.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
.FilterIndex = 2 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
.InitialFileName = ThisWorkbook.Path & "\"
.InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
If oFD.Show = 0 Then Exit Function 'показывает диалог
'цикл по коллекции выбранных в диалоге файлов
Dim arr As Variant
ReDim arr(1 To .SelectedItems.Count)
For lf = 1 To .SelectedItems.Count
arr(lf) = .SelectedItems(lf) 'считываем полный путь к файлу
Next
End With
ShowFileDialog = arr
End Function
|