Из многих листов интересуют листы с определенным наименованием, штук 10 листов. В этих листах заранее известны нужные номера строк. например, строки 3,9,70. Строки одинаковы для нужных листов.
Строки 3,9,70 листа "Тест" первого заполненного файла перенести в соответствующие 3,9,70 строки листа "Тест" второго заполненого файла. Далее, строки 3,9,70 листа "Данные" первого файла перенессти в соответствующие строки листа "Данные" второго файла.
Строки перенсти полностью (entire row) и вставить как формулы.
Если бы не большие объемы - можно сделать вручную. Но объемы не маленькие( Вручную запарно будет копировать 150 строк определенных одного листа в другой такой же лист второго файла, перезаписывая данные. И так для всех нужных листов.. Один раз бы задать: * какие номера строк * с каких листов первого файла * перезаписать соответствующие строки соответствущих по наименованиям листов второго файла.
Исходно: две книги.
Из многих листов интересуют листы с определенным наименованием, штук 10 листов. В этих листах заранее известны нужные номера строк. например, строки 3,9,70. Строки одинаковы для нужных листов.
Строки 3,9,70 листа "Тест" первого заполненного файла перенести в соответствующие 3,9,70 строки листа "Тест" второго заполненого файла. Далее, строки 3,9,70 листа "Данные" первого файла перенессти в соответствующие строки листа "Данные" второго файла.
Строки перенсти полностью (entire row) и вставить как формулы.
Если бы не большие объемы - можно сделать вручную. Но объемы не маленькие( Вручную запарно будет копировать 150 строк определенных одного листа в другой такой же лист второго файла, перезаписывая данные. И так для всех нужных листов.. Один раз бы задать: * какие номера строк * с каких листов первого файла * перезаписать соответствующие строки соответствущих по наименованиям листов второго файла.w00t
For i = 0 To UBound(arrRow) For j = 0 To UBound(arrSheet) ThisWorkbook.Worksheets(arrSheet(j)).Activate Range(Cells(arrRow(i), 1), Cells(arrRow(i), 200)).Copy Destination:=w1.Worksheets(arrSheet(j)).Cells(arrRow(i), 1) Next j Next i w1.Save w1.Close End Sub
[/vba]
Вот основа, насколько понял [vba]
Код
Option Explicit
Public Sub copyData() Dim w1 As Workbook Dim str1 As String Dim arrSheet, arrRow Dim i As Integer, j%
For i = 0 To UBound(arrRow) For j = 0 To UBound(arrSheet) ThisWorkbook.Worksheets(arrSheet(j)).Activate Range(Cells(arrRow(i), 1), Cells(arrRow(i), 200)).Copy Destination:=w1.Worksheets(arrSheet(j)).Cells(arrRow(i), 1) Next j Next i w1.Save w1.Close End Sub
пишет subscript out of range. В качестве вывода указал файл с первого поста. То есть источник - файл ваш. Из него данные в файл из первого поста, соответственно, к которому путь и указал локально на ПК.
Попутно маленький вопрос. Как правильно сделать цикл, чтобы повторить эту процедуру для всех файлов в определенной папке. В примере это ThisWorkbook.Path (можно и в нем, только тогда 0t0.xlsm бы исключить из которого растиражирование на все другие фалы в папке произойдет...)
пишет subscript out of range. В качестве вывода указал файл с первого поста. То есть источник - файл ваш. Из него данные в файл из первого поста, соответственно, к которому путь и указал локально на ПК.
Попутно маленький вопрос. Как правильно сделать цикл, чтобы повторить эту процедуру для всех файлов в определенной папке. В примере это ThisWorkbook.Path (можно и в нем, только тогда 0t0.xlsm бы исключить из которого растиражирование на все другие фалы в папке произойдет...)w00t
Немного разобрался, но не до конца. Этот костяк отлично работает.
Понял, почему ошибка была. В книге-приемнике небыло листа, точно совпадающего с листом книги-источника по наименованию.
Пример: в источнике листы называются: "Тест", "Тест2", "Тест3", "Тест4" В приемнике "Тест", "Тест2", "Тест3"
То есть, здесь конфликт (в приемнике нет листа Тест4). Можете помочь подправить, чтобы в таком случае, данные с источника, с листов наименованиями "Тест", "Тест2", "Тест3" скопированы в соответствующие листы приемника? А раз один лист в приемнике не совпал с источником, то вывести сообщение?
И правильно ли,если цикл?
[vba]
Код
Sub ProcessFiles()
Dim Filename, Pathname As String Dim w1 As Workbook Dim w2 As Workbook
Dim str1 As String Dim arrSheet, arrRow Dim i As Integer, j%
Pathname = ActiveWorkbook.Path & "\" Filename = Dir(Pathname & "*.xlsx") Do While Filename <> "" Set w1 = Workbooks.Open(Pathname & Filename) ThisWorkbook.Activate For i = 0 To UBound(arrRow) For j = 0 To UBound(arrSheet) ThisWorkbook.Worksheets(arrSheet(j)).Activate Range(Cells(arrRow(i), 1), Cells(arrRow(i), 200)).Copy Destination:=w1.Worksheets(arrSheet(j)).Cells(arrRow(i), 1) Next j Next i w1.Save w1.Close Filename = Dir() Loop End Sub
[/vba]
Немного разобрался, но не до конца. Этот костяк отлично работает.
Понял, почему ошибка была. В книге-приемнике небыло листа, точно совпадающего с листом книги-источника по наименованию.
Пример: в источнике листы называются: "Тест", "Тест2", "Тест3", "Тест4" В приемнике "Тест", "Тест2", "Тест3"
То есть, здесь конфликт (в приемнике нет листа Тест4). Можете помочь подправить, чтобы в таком случае, данные с источника, с листов наименованиями "Тест", "Тест2", "Тест3" скопированы в соответствующие листы приемника? А раз один лист в приемнике не совпал с источником, то вывести сообщение?
И правильно ли,если цикл?
[vba]
Код
Sub ProcessFiles()
Dim Filename, Pathname As String Dim w1 As Workbook Dim w2 As Workbook
Dim str1 As String Dim arrSheet, arrRow Dim i As Integer, j%
Pathname = ActiveWorkbook.Path & "\" Filename = Dir(Pathname & "*.xlsx") Do While Filename <> "" Set w1 = Workbooks.Open(Pathname & Filename) ThisWorkbook.Activate For i = 0 To UBound(arrRow) For j = 0 To UBound(arrSheet) ThisWorkbook.Worksheets(arrSheet(j)).Activate Range(Cells(arrRow(i), 1), Cells(arrRow(i), 200)).Copy Destination:=w1.Worksheets(arrSheet(j)).Cells(arrRow(i), 1) Next j Next i w1.Save w1.Close Filename = Dir() Loop End Sub
Do While Filename <> "" If wb.Name <> Filename Then
With Workbooks.Open(Pathname & Filename) 'файл приемник For i = 0 To UBound(arrSheet) If Evaluate("ISREF('" & arrSheet(i) & "'!A1)") Then For j = 0 To UBound(arrRow) wb.Sheets(arrSheet(i)).Cells(arrRow(j), 1).Resize(, 200).Copy Sheets(arrSheet(i)).Cells(arrRow(j), 1) Next j Else MsgBox "File '" & Filename & "'; sheet '" & arrSheet(i) & "' not found", 48 End If Next i .Close True DoEvents End With
End If Filename = Dir() Loop Application.ScreenUpdating = True End Sub
[/vba]
Наверное, как-то вот так вот:
[vba]
Код
Sub ProcessFiles() Dim Filename As String, Pathname As String Dim wb As Workbook Dim arrSheet, arrRow Dim i As Integer, j%
Do While Filename <> "" If wb.Name <> Filename Then
With Workbooks.Open(Pathname & Filename) 'файл приемник For i = 0 To UBound(arrSheet) If Evaluate("ISREF('" & arrSheet(i) & "'!A1)") Then For j = 0 To UBound(arrRow) wb.Sheets(arrSheet(i)).Cells(arrRow(j), 1).Resize(, 200).Copy Sheets(arrSheet(i)).Cells(arrRow(j), 1) Next j Else MsgBox "File '" & Filename & "'; sheet '" & arrSheet(i) & "' not found", 48 End If Next i .Close True DoEvents End With
End If Filename = Dir() Loop Application.ScreenUpdating = True End Sub
чтобы в таком случае, данные с источника, с листов наименованиями "Тест", "Тест2", "Тест3" скопированы в соответствующие листы приемника? А раз один лист в приемнике не совпал с источником, то вывести сообщение?
добавил код [vba]
Код
Option Explicit
Public Sub copyData() Dim w1 As Workbook Dim str1 As String Dim arrSheet, arrRow Dim i As Integer, j% Dim oDict
arrSheet = Array("Тест", "Тест4", "Тест2") 'список листов arrRow = Array(3, 9, 20) 'список номеров строк str1 = ThisWorkbook.Path & "\out.xlsx" 'имя файла вывода Set w1 = Workbooks.Open(str1) ThisWorkbook.Activate Set oDict = CreateObject("Scripting.Dictionary") oDict.CompareMode = 1 For i = 0 To UBound(arrRow) For j = 0 To UBound(arrSheet) str1 = arrSheet(j) If SheetExists(str1, w1) Then ThisWorkbook.Worksheets(arrSheet(j)).Activate Range(Cells(arrRow(i), 1), Cells(arrRow(i), 200)).Copy Destination:=w1.Worksheets(arrSheet(j)).Cells(arrRow(i), 1) Else If Not oDict.exists(str1) Then oDict.Add str1, 1 MsgBox "В целевом файле отсутствует лист: " & str1, 48, "Отсутствие листа" End If End If Next j Next i w1.Save w1.Close Set oDict = Nothing End Sub
Function SheetExists(SheetName As String, wb As Workbook) As Boolean On Error Resume Next SheetExists = Not wb.Sheets(SheetName) Is Nothing End Function
чтобы в таком случае, данные с источника, с листов наименованиями "Тест", "Тест2", "Тест3" скопированы в соответствующие листы приемника? А раз один лист в приемнике не совпал с источником, то вывести сообщение?
добавил код [vba]
Код
Option Explicit
Public Sub copyData() Dim w1 As Workbook Dim str1 As String Dim arrSheet, arrRow Dim i As Integer, j% Dim oDict
arrSheet = Array("Тест", "Тест4", "Тест2") 'список листов arrRow = Array(3, 9, 20) 'список номеров строк str1 = ThisWorkbook.Path & "\out.xlsx" 'имя файла вывода Set w1 = Workbooks.Open(str1) ThisWorkbook.Activate Set oDict = CreateObject("Scripting.Dictionary") oDict.CompareMode = 1 For i = 0 To UBound(arrRow) For j = 0 To UBound(arrSheet) str1 = arrSheet(j) If SheetExists(str1, w1) Then ThisWorkbook.Worksheets(arrSheet(j)).Activate Range(Cells(arrRow(i), 1), Cells(arrRow(i), 200)).Copy Destination:=w1.Worksheets(arrSheet(j)).Cells(arrRow(i), 1) Else If Not oDict.exists(str1) Then oDict.Add str1, 1 MsgBox "В целевом файле отсутствует лист: " & str1, 48, "Отсутствие листа" End If End If Next j Next i w1.Save w1.Close Set oDict = Nothing End Sub
Function SheetExists(SheetName As String, wb As Workbook) As Boolean On Error Resume Next SheetExists = Not wb.Sheets(SheetName) Is Nothing End Function
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
