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 ' обнулить ссылку
|
