Здравствуйте, помогите пожалуйста подкорректировать макрос для переноса данных из одной книги в другую.
Есть файл Источник "Исходные данные.xlsx" из которого необходимо регулярно обновлять данные в файл "Сохраненые файлы.xlsm"
При этом есть условия выбора:
1. Выбирать только те строки где есть значения, если пусто то пропускаем всю строку во всех столбцах
2. Чтобы обновление работало если в файле Исходные данные.xlsx заголовок начинается не с первой строки а в файле Сохранённые файлы.xlsm есть другие листы
3. При запуске файл "Сохраненые файлы.xlsm" должен обновляться заново
4. Необходимо добавить 2 столба в файл "Сохраненые файлы.xlsm" с разницей чисел столбца "Шапка 13"- - которые вновь обновились от такого же столбца но в другой книге
Подскажите пожалуйста как можно это скорректировать или направьте пожалуйста на источник где можно почитать/посмотреть похожие алгоритмы
Сейчас работает только если в книгах по одному листу и начала данных с ячейки А1:
Код |
---|
Sub CopyData()
Dim wrkSv As Workbook
'Открываем книгу источник откуда будем копировать данные
Set wrkSv = Workbooks.Open("C:\Users\sega4\OneDrive\Рабочий стол\Первый проект\Исходные данные.xlsx")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Workbooks("Исходные данные.xlsx").Activate
Sheets("Лист1").Select
Sheets("Лист1").Copy After:=Workbooks("Сохраненые файлы.xlsm").Sheets(1)
'Закрываем книгу откуда мы скопировали данные
Workbooks("Исходные данные.xlsx").Close
Dim wbkX As Workbook 'книга
Dim shtSv As Worksheet, shtX As Worksheet 'листы
Dim rngSv As Range, rngX As Range 'диапазоны
Dim NrowSv As Long, NrowX As Long 'число строк
Dim NcolSv As Integer, NcolX As Integer 'число столбцов
Dim TitleSv, TitleX '"будущие" массивы заголовков
Dim i As Long, j As Long 'счетчики циклов
Dim rngCopy As Range, rngPaste As Range 'что копировать и куда вставить
Set wbkX = ThisWorkbook
'= 1 == для листа "реестр" ======================
Set shtSv = wbkX.Worksheets("реестр")
Set rngSv = shtSv.Range("A1").CurrentRegion
NrowSv = rngSv.Rows.Count
NcolSv = rngSv.Columns.Count
TitleSv = rngSv.Rows(1)
'= 2 == Цикл по всем листам, кроме "Лист1" ======================
For Each shtX In wbkX.Worksheets
Select Case shtX.Name
Case "реестр" 'для листа "реестр" - ничего не делаем!
Case Else '-- 3 -- для прочих листов ---------
Set rngX = shtX.Range("A1").CurrentRegion
NrowX = rngX.Rows.Count
NcolX = rngX.Columns.Count
TitleX = rngX.Rows(1)
'-- 4 -- поиск совпадающих заголовков ---------
For i = 1 To NcolSv
For j = 1 To NcolX
'-- 5 -- если заголовки совпали, то ...
If TitleSv(1, i) = TitleX(1, j) Then
'- 6 - что копировать ----
Set rngCopy = Range(rngX.Cells(2, j), rngX.Cells(NrowX, j))
'- 7 - куда вставить ----
Set rngPaste = rngSv.Cells(1 + 1, i).Resize(NrowX - 1, 1)
'- 8 - копирование через буфер обмена -----
rngCopy.Copy
rngPaste.PasteSpecial
End If
Next j
Next i
'-- 9 -- определить новые размеры диапазона на листе "Лист1" ---
Set rngSv = shtSv.Range("A1").CurrentRegion
NrowSv = rngSv.Rows.Count
End Select
Next shtX '== конец цикла по листам ========================================
'Удаление листа
Worksheets("Лист1").Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
|
Заранее благодарю