Dim arr, j%, d%, lngRow&, s$ Dim xl As Excel.Application Dim oWbk As Excel.Worksheet Dim FROMROWSCOUNT(6) As Long Dim FROMCOLSCOUNT() As Integer Dim sheet_arr Dim i As Integer sheet_arr = Array("kccatal", "kcclient", "kcsr", "kcsales", "kcwh", "kcrest") Set xl = New Excel.Application ' "запустить" Excel ' диалог выбора файлОВ (можно выбрать несколько), результат выбора - в массив arr = xl.GetOpenFilename("Файл оператора (*.xls), *.xls", 1, "Выбери себе ...", , True) 'If arr <> False Then ' если что-то выбранно For i = 1 To 6 ' ссылка на лист во вновь добавленной книге Set oWbk = xl.Workbooks.Add.Worksheets(i) oWbk.Name = sheet_arr(i) xl.ScreenUpdating = False FROMROWSCOUNT(i) = xl.Worksheets(sheet_arr(i)).UsedRange.Rows.Count 'количество строк FROMCOLSCOUNT(i) = xl.Worksheets(sheet_arr(i)).UsedRange.Columns.Count 'количество столбцов ' данные начнем вставлять с первой строки lngRow = 1 ' цикл по всем выбранным книгам For j = 0 To UBound(arr) s = arr(j) d = InStrRev(s, "\") ' формула для "первой" ячейки ' ='Папка_с_книгой[Имя_книги]ЛистОткудаКопируемДанные!'АдресПервойЯчейкиДиапазонаКоторыйКопируем oWbk.Cells(lngRow, 1).Formula = "='" & Left(s, d) & "[" & Mid(s, d + 1) & "]" & sheet_arr(i) & "'!" & A1 ' "протягиваем" формулу вширь и вглубь w.Range(w.Cells(lngRow, 1), w.Cells(lngRow, FROMCOLSCOUNT(i))).FillRight w.Range(w.Cells(lngRow, 1), w.Cells(lngRow + FROMROWSCOUNT(i) - 1, FROMCOLSCOUNT(i))).FillDown ' начальная строка для вставки данных из следующей книги lngRow = lngRow + FROMROWSCOUNT(i) Next j ' освободить память занятую массивом Erase arr ' заменить формулы их значениями w.Range(w.Cells(1, 1), w.Cells(lngRow - 1, FROMCOLSCOUNT(i))).Copy w.Range(w.Cells(1, 1)).PasteSpecial xlPasteValues ' "загнать" что-то небольшое в буфер обмена w.Range(w.Cells(1, 1)).Copy w.Name = "Сравнение" ' переименовать лист Set w = Nothing ' обнулить ссылку xl.ScreenUpdating = True xl.Visible = True ' новая книга! MsgBox "Ok" Next i ' Else ' не выбрано ни одного файла ' MsgBox "Не очень-то и хотелось..." ' xl.Quit ' закрыть Excel за ненадобностью 'End If Set xl = Nothing ' обнулить ссылку |