Подскажите пожалуйста можно ли доработать макрос чтобы он копировал не все столбцы а конкретные. которые заданы на листе Result В источнике более 200 тыс. строк
Код
Sub Макрос3()
Dim arrData(), arrResult(), fRegion
Dim CriteriaColumn As Integer
Dim CurrentRow As Long, i As Long, j As Long
fRegion = "Калининград"
CriteriaColumn = 5
arrData = Sheets("Data").Cells(2, 1).CurrentRegion.Value
ReDim arrResult(1 To UBound(arrData, 1), 1 To UBound(arrData, 2))
i = 1
CurrentRow = 1
For j = 1 To UBound(arrData, 2)
arrResult(CurrentRow, j) = arrData(i, j)
Next j
CurrentRow = CurrentRow + 1
For i = 2 To UBound(arrData, 1)
If arrData(i, CriteriaColumn) = fRegion Then
For j = 1 To UBound(arrData, 2)
arrResult(CurrentRow, j) = arrData(i, j)
Next j
CurrentRow = CurrentRow + 1
End If
Next i
With Sheets("result")
.Cells.Clear
.Range(.Cells(1, 1), .Cells(CurrentRow, UBound(arrData, 2))).Value = arrResult
End With
End Sub
И как можно его же запускать если это разные книги, а не листы?
Указание активной книги/листа через команду Workbook("Имя книги").Activate не работает
PMO87, возможно такое можно было бы сделать, как вы хотите, но проблема заключается в том, что у вас в таблице столбцы имеют одинаковое название и отличить столбец с названием "created_date", от столбца "created_date" - невозможно. Представьте таблицу из 40 столбцов с одинаковыми названиями шапки "Данные". Как отличить второй столбец от пятого, от десятого, от сорокового? Никак. Я вам по секрету скажу, обычно таблицы не содержат столбцов с одинаковым названием, т.к. это может запутать пользователя. Обычно в таблицах делают названия столбцов уникальные. Соответственно, если ваша таблица имела бы уникальные название столбцов, то можно было бы что-нибудь придумать. А так, я вам предлагаю в макросе один раз указать номера нужных вам столбцов, например, 1, 2, 5, 6 и макрос уже будет вытягивать нужные вам столбцы не по названию столбцов, т.к. они у вас одинаковые, а по номеру столбца. Касательно того, что данные находятся в другом файле, а не на другом листе, я вам предлагаю открыть файл с макросом и открыть ваш файл с данными, т.е. у вас должно быть открыто сразу 2 файла и запустите макрос. Почитайте комментарии зелёным цветом в коде и укажите цифрами нужные вам столбцы.
Код
Sub Сбор_данных()
Dim arrData(), arrResult(), HeaderNumbers, Region As String
Dim CriteriaColumn As Long, CurrentRow As Long, i As Long, j As Long
Dim ReportWb As Workbook, TmpWb As Workbook, MsgResult As VbMsgBoxResult
Region = "Калининград" 'укажите нужный регион
CriteriaColumn = 5 'номер столбца с регионами
HeaderNumbers = Array(1, 2, 5, 6) 'укажите номера нужных столбцов
'перебираем все открытые книги в поиске файла с отчетом
For Each TmpWb In Workbooks
If Not TmpWb.Name = ThisWorkbook.Name And TmpWb.Name <> "PERSONAL.XLS*" Then
MsgResult = MsgBox(TmpWb.Name, vbYesNoCancel + vbDefaultButton2 + vbQuestion, "Выберите файл с отчётом")
If MsgResult = vbCancel Then Exit Sub
If MsgResult = vbYes Then
Set ReportWb = Workbooks(TmpWb.Name)
Exit For
End If
End If
Next TmpWb
If ReportWb Is Nothing Then
MsgBox "Вы не указали файл с отчётом! Откройте файл с отчётом!", 48, "Ошибка"
Exit Sub
End If
arrData = ReportWb.Sheets(1).Cells(2, 1).CurrentRegion.Value 'ReportWb.Sheets("Data")
ReDim arrResult(1 To UBound(arrData, 1), 1 To UBound(HeaderNumbers, 1) + 1)
'шапка таблицы
For i = 1 To UBound(HeaderNumbers, 1) + 1
arrResult(1, i) = arrData(1, HeaderNumbers(i - 1))
Next i
CurrentRow = 1
For i = 2 To UBound(arrData, 1)
If arrData(i, CriteriaColumn) = Region Then
CurrentRow = CurrentRow + 1
For j = 1 To UBound(HeaderNumbers, 1) + 1
arrResult(CurrentRow, j) = arrData(i, HeaderNumbers(j - 1))
Next j
End If
Next i
'выгрузка результата на лист
With ThisWorkbook.Sheets("result") 'если ваш лист имеет другое название напишите его вместо слово Result
.Cells.Clear
.Range(.Cells(1, 1), .Cells(CurrentRow, UBound(arrResult, 2))).Value = arrResult
End With
MsgBox "Данные собраны!", vbInformation, "Конец"
End Sub
PMO87, касательно вашего вопроса "как сделать, чтобы код копировал данные с городами которые не начинаются на "Ка" т.е. если выбирать фильтр (<>Ка*)". Вот ответ, почитайте зелёный комментарий в коде (строка If Not arrData(i, CriteriaColumn) Like "Ка*" Then)
Код
Sub Сбор_данных()
Dim arrData(), arrResult(), HeaderNumbers, Region As String
Dim CriteriaColumn As Long, CurrentRow As Long, i As Long, j As Long
Dim ReportWb As Workbook, TmpWb As Workbook, MsgResult As VbMsgBoxResult
'Region = "Калининград" 'укажите нужный регион
CriteriaColumn = 5 'номер столбца с регионами
HeaderNumbers = Array(1, 2, 5, 6) 'укажите номера нужных столбцов
'перебираем все открытые книги в поиске файла с отчетом
For Each TmpWb In Workbooks
If Not TmpWb.Name = ThisWorkbook.Name And TmpWb.Name <> "PERSONAL.XLS*" Then
MsgResult = MsgBox(TmpWb.Name, vbYesNoCancel + vbDefaultButton2 + vbQuestion, "Выберите файл с отчётом")
If MsgResult = vbCancel Then Exit Sub
If MsgResult = vbYes Then
Set ReportWb = Workbooks(TmpWb.Name)
Exit For
End If
End If
Next TmpWb
If ReportWb Is Nothing Then
MsgBox "Вы не указали файл с отчётом! Откройте файл с отчётом!", 48, "Ошибка"
Exit Sub
End If
arrData = ReportWb.Sheets(1).Cells(2, 1).CurrentRegion.Value 'ReportWb.Sheets("Data")
ReDim arrResult(1 To UBound(arrData, 1), 1 To UBound(HeaderNumbers, 1) + 1)
'шапка таблицы
For i = 1 To UBound(HeaderNumbers, 1) + 1
arrResult(1, i) = arrData(1, HeaderNumbers(i - 1))
Next i
CurrentRow = 1
For i = 2 To UBound(arrData, 1)
If Not arrData(i, CriteriaColumn) Like "Ка*" Then 'вот тут условие отбора региона
CurrentRow = CurrentRow + 1
For j = 1 To UBound(HeaderNumbers, 1) + 1
arrResult(CurrentRow, j) = arrData(i, HeaderNumbers(j - 1))
Next j
End If
Next i
'выгрузка результата на лист
With ThisWorkbook.Sheets("result")
.Cells.Clear
.Range(.Cells(1, 1), .Cells(CurrentRow, UBound(arrResult, 2))).Value = arrResult
End With
MsgBox "Данные собраны!", vbInformation, "Конец"
End Sub
DirName = 'указываем папку где лежит исходный файл в кавычках, либо ссылку на ячейку, где записан адрес папки
FileN = DirName & "\[название файла-донора].xlsx"
'Открываем файл-донор в режиме ReadOnly
Workbooks.Open Filename:=FileN, ReadOnly:=True
Set wb = ActiveWorkbook
'Делаем что хотим с ним, например, нам надо в нашу книгу в ячейку А1 листа 1 из донора перетащить ячейку B2 с листа 4:
ThisWorkbook.WorkSheets("Лист 1").cells(1,1)=wb.WorkSheets("Лист 4").cells(2,2)
'Ну и пока книга-донор открыта, обращаться к ней можно через объект wb, хоть циклами оттуда данные тащите, хоть столбцами и строками, как угодно.
'Донор открыт в ReadOnly, так что исходные данные в нем не пострадают, что бы вы не сделали.
'как только все данные перетянули в свою книгу, донора надо закрыть:
wb.Close
При этом донор откроется именно на период вытаскивания из него данных, не надо держать его открытым постоянно. Мне такой подход удобен тем, что так реализовал формирование реестра документов из сетевого источника, который формируется независимо, т.е. я запускаю свою книгу, запускаю макрос, он подтягивает из локальной сети донора, открывает его в ридонли, перетаскивает из него то что мне надо и закрывает его. Тот, кто работает с донором в этот момент напрямую в нем, даже не замечает, что из этого файла что-то кто-то скопировал себе.
New, JayBhagavan. Aiden_ko можете пожалуйста подсказать как поставить фильтр для условий чтобы к примеру регион выбирал только в том случае если к примеру столбец created_date(где год) написан был равен нынешнему году(переменная величина), и время с 10.00 до 18.00?