Доброго времени суток. Задался вопросом о "сборе" данных из множества книг в одну. Во всех книгах имеется лист , на котором собираются данные ( в основном ссылки с дуругих листов в книге). Строки, столбцы, на этом листе, во всех книгах постоянны. Как сделать так, что бы из всех "выбранных" книг, копировались данные (срока с данными) в другую, общую книгу. То есть из каждой новой книги информация копировалась бы в последующую строку, в новой книги.Почитал довольно много тем с похожим вопросом. Заинтересовался кодом ниже. Но есть проблемы: копирует не те строки которые необходимо+такое ощущение, что проводит поиск файлов эксель по всему компу. В чем проблема/ошибка, подскажите пожалуйста.
| Код |
|---|
Sub Собрать_данные()
Application.ScreenUpdating = False
' Макрос собирает данные на активном листе активной книги из всех листов "Форма" xls файлов заданной директории,
Dim ImenaListovSbora: ImenaListovSbora = Array("Сводный_лист")
Const FirstRow_Cel& = 4 ' Номер строки начала построения
Const FirstRow& = 4 ' Номер строки начала сбора данных (ниже шапки)
Dim i&, LastRow&, LastRow_Cel&
Dim ShCel As Worksheet, Sh As Worksheet, wb_Tek As Workbook
Dim MyPath$, MyFileName$, MyFullName$
Set ShCel = ActiveSheet
LastRow_Cel = FirstRow_Cel
With ShCel
i = .UsedRange.Rows.Count + .UsedRange.Row - 1
If i < FirstRow_Cel Then i = FirstRow_Cel
.Rows(FirstRow_Cel & ":" & i).ClearContents
End With
MyPath = Trim$(ShCel.[C1])
If Right$(MyPath, 1) <> "" Then MyPath = MyPath & ""
MyFileName = Dir(MyPath & "*.xls*")
Do Until MyFileName = ""
MyFullName = MyPath & MyFileName
Set wb_Tek = Workbooks.Open(Filename:=MyFullName, UpdateLinks:=0, ReadOnly:=True)
For Each Sh In wb_Tek.Worksheets
For i = 0 To UBound(ImenaListovSbora)
If Sh.Name = ImenaListovSbora(i) Then
With Sh
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.Cells(FirstRow, 1), .Cells(LastRow, 8)).Copy
ShCel.Cells(LastRow_Cel, 1).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
LastRow_Cel = LastRow_Cel + LastRow - FirstRow + 1
End With
End If
Next
Next Sh
wb_Tek.Close SaveChanges:=False
MyFileName = Dir
Loop
With ShCel
.Range(.Cells(LastRow_Cel - 1, 1), .Cells(LastRow_Cel - 1, 8)).Copy
.Cells(LastRow_Cel, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.Cells(LastRow_Cel, 2).Select
End With
End Sub
|
