Мне собственно полностью реализация не нужна - частично работоспособный макрос есть. Часть макроса не работает. Если кто-то подскажет почему не работает и/или как ее можно заставить работать - буду очень благодарен.
Сам макрос:
Option Explicit
Sub CombineTables()
Dim BazaWb As Workbook 'текущая книга (общий файл)
Dim BazaSht As Worksheet 'лист База покупателей в общем файле
Dim iTempFileName As String 'имя по-очерёдно открываемого файла
Dim iPath As String 'путь к папке, где лежат все файлы
Dim iLastRowBaza As Long 'последняя заполненная строка в общем файле в столбце D
Dim iLastRowTempWb As Long 'последняя заполненная строка в по-очерёдно открываемом файле в столбце A
Dim iLastColTempWb 'последний столбец с инфо в по-очерёдно открываемом файле
Dim iNumFiles As Long 'количество открываемых файлов
Dim IsHeader As Boolean 'скопирована ли шапка таблицы
Dim CodeRng As Range 'ячейка с кодом сотрудника (надписью "Код")
Dim CompRng As Range 'ячейка с надписью "Из них - Компания:"
Dim StaffRng As Range 'ячейка снадписью "Сотрудник:"
Dim firstAddress As String
Dim n As Long 'счётчик
Dim k As Long 'счётчик
Dim m As Long 'счётчик
Dim iLastRowTbl As Long 'номер последний строки в текущей таблице
Dim iTablesCnt As Long 'количество скопированных таблиц
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlManual
Set BazaWb = ThisWorkbook
Set BazaSht = BazaWb.Worksheets("Расчет")
iPath = BazaWb.Path & "\"
iTempFileName = Dir(iPath & "*.xlsx")
Do While iTempFileName <> ""
If iTempFileName = BazaWb.Name Then GoTo iNext:
With .Workbooks.Open _
(Filename:=iPath & iTempFileName, UpdateLinks:=False, ReadOnly:=True)
If Not IsShtPresent("Заказы") Then
Application.ScreenUpdating = True
MsgBox "Листа с названием ""Заказы"" в активной книге нет! ", 48, "Ошибка"
Exit Sub
End If
iNumFiles = iNumFiles + 1
'Поиск меток в меню
With .Worksheets("Заказы")
.UsedRange.EntireRow.Hidden = False
'ищем ячейку с "Company"
Set CompRng = .Columns(1).Find(What:="Из них - Компания:", LookIn:=xlFormulas, LookAt:=xlWhole)
'ищем ячейку с "Staff"
Set StaffRng = .Columns(1).Find(What:="Сотрудник:", LookIn:=xlFormulas, LookAt:=xlWhole)
'ищем ячейку с "Code"
Set CodeRng = .Columns(4).Find(What:="Код", LookIn:=xlFormulas, LookAt:=xlWhole)
До данного момента макрос работоспособен.
Неработающая часть:
For k = 1 To BazaWb.BazaSht.Cells(Rows.Count, 4).End(xlUp).Row
If BazaWb.BazaSht.Cells(k, 4).Value = CodeRng.Offset(1, 0).Value Then
For m = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
If BazaWb.BazaSht.Cells(k, m) = "" Then
BazaWb.BazaSht.Cells(k, m).Value = StaffRng.Offset(0, 1).Value
BazaWb.BazaSht.Cells(k, m + 1).Value = CompRng.Offset(0, 1).Value
End If
Next m
End If
Next k
Начиная с этого момента макрос также полностью работоспособен
End With
.Close saveChanges:=False
End With
iNext:
iTempFileName = Dir
Loop
Range("B2:B3").Merge
Columns("B:D").AutoFit
.Calculation = xlAutomatic
.DisplayAlerts = True
.ScreenUpdating = True
End With
MsgBox "Информация собрана из " & iNumFiles & " файлов"
End Sub
Function IsShtPresent(iShtName As String) As Boolean
'проверяем существование листа в книге
Dim iShtTest As Worksheet
On Error Resume Next
Set iShtTest = ActiveWorkbook.Sheets(iShtName)
If iShtTest Is Nothing Then
IsShtPresent = False
Else
IsShtPresent = True
End If
End Function
Просто никак не могу реализовать копирование данных :(
Я его тестировал по кускам - он находит данные, файлы и т.д. правильно, а вот как их скопировать - неизвестно :(
