Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Скопировать данные конкретных столбцов из одной таблицы в другую
 
#1
16.09.2021 19:06:23
Доброго времени планетяни!

Подскажите пожалуйста можно ли доработать макрос чтобы он копировал не все столбцы а конкретные. которые заданы  на листе 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 не работает
Изменено: vikttur - 16.09.2021 21:04:22
 
 
 
#2
17.09.2021 00:14:58
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
Изменено: New - 17.09.2021 01:06:43
 
 
 
#3
17.09.2021 09:01:15
New огромное спасибо!!! то что нужно, только убрал MsgBoxы
Изменено: vikttur - 17.09.2021 09:44:34
 
 
 
#4
17.09.2021 15:49:11
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
Изменено: New - 17.09.2021 15:51:53
 
 
 
#5
17.09.2021 17:29:57
New спасибо большое!
 
 
 
#6
17.09.2021 18:34:52
Попробуйте логику вот такую:

Код
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
При этом донор откроется именно на период вытаскивания из него данных, не надо держать его открытым постоянно. Мне такой подход удобен тем, что так реализовал формирование реестра документов из сетевого источника, который формируется независимо, т.е. я запускаю свою книгу, запускаю макрос, он подтягивает из локальной сети донора, открывает его в ридонли, перетаскивает из него то что мне надо и закрывает его. Тот, кто работает с донором в этот момент напрямую в нем, даже не замечает, что из этого файла что-то кто-то скопировал себе.
Изменено: Aiden_ko - 17.09.2021 18:41:08
 
 
 
#7
17.09.2021 23:37:31
Aiden_ko, можно сократить:
Код
Workbooks.Open Filename:=FileN, ReadOnly:=True
Set wb = ActiveWorkbook
до:
Код
Set wb = Workbooks.Open(Filename:=FileN, ReadOnly:=True)

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
 
 
#8
20.09.2021 14:24:03
New, JayBhagavan. Aiden_ko можете пожалуйста подсказать как поставить фильтр для условий чтобы к примеру регион выбирал только в том случае если к примеру  столбец created_date(где год) написан был равен нынешнему году(переменная величина), и время с 10.00 до 18.00?  
 
 
 
#9
20.09.2021 14:36:37
PMO87, в коде от New в 37 строку добавьте через И (and) все Ваши желаемые условия.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
 
 
#10
21.09.2021 07:25:17
JayBhagavan почему то не работает И (and) при таком условии - выбирает только первое значение
К примеру в строке:
Код
If Not arrData(i, CriteriaColumn) Like "Калу*" And "Иж*"
все равно итогом выводит все значения кроме Калуга

Пробовал без Like и через переменные все равно не работает
 
 
 
#11
21.09.2021 07:41:07
Проверьте:
Код
If Not arrData(i, CriteriaColumn) Like "Калу*" And Not arrData(i, CriteriaColumn) Like "Иж*"

или
Код
If Not (arrData(i, CriteriaColumn) Like "Калу*" Or arrData(i, CriteriaColumn) Like "Иж*")

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
 
 
Страницы: 1
Наверх