Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Сравнение по столбцу и копирование данных из двух книг в третью
 
#1
07.04.2021 23:31:42
Вечер добрый, необходима помощь.
Есть 2 файла с большим количеством строк, шапки разные за исключением столбца А.
Необходимо сделать сравнение по столбцу А на наличие одинаковых записей и копировать их в файл 3 в виде
Столбцы А, B и С из файла 1, далее в столбец D копировать столбец С из файла 2, в столбец E столбец G из файла 2.

Файлы для примера прикрепил.
Много где читал, мне показалось, что лучше всего подходит для такого решения Powershell?(в котором так же мало соображаю как и в VB)

Из моих попыток скрипт на VB, немного переделал под себя(но это не совсем то, что нужно.)
Код
Sub test()
    On Error Resume Next: Application.ScreenUpdating = False
    Dim sh1 As Worksheet: Set sh1 = Worksheets(1)
    Dim sh2 As Worksheet: Set sh2 = Worksheets(2)
    Dim sh3 As Worksheet: Set sh3 = Worksheets(3)
    sh3.UsedRange.Clear ' очистка листа от прежних данных
    Dim cell As Range, ra As Range, ForCopy As Range
    
    ' перебираем все заполненные ячейки в столбце Е
    Set ra = sh1.Range([e1], Range("e" & sh1.Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
    
    For Each cell In ra.Cells
        If Not sh2.Range("a:a").Find(cell) Is Nothing Then ' если аналогичный номер есть в столбце А
            If ForCopy Is Nothing Then Set ForCopy = cell Else Set ForCopy = Union(ForCopy, cell)
            If ForCopy.Cells.Count > 1000 Then
                ForCopy.EntireRow.Copy sh3.Range("a" & sh3.Rows.Count).End(xlUp).Offset(1)
                Set ForCopy = Nothing
            End If
        End If
    Next cell
    ForCopy.EntireRow.Copy sh3.Range("a" & sh3.Rows.Count).End(xlUp).Offset(1)
    sh3.UsedRange.EntireColumn.AutoFit: sh3.Rows(1).Delete
    sh3.Activate
End Sub
 
 
 
#2
08.04.2021 06:40:50
-в файле 1 удалить все дубликаты по столбцы А;
- далее, перенести с файла 1 столбцы А, В, С;
- далее, по столбцу А вытянуть данные столбцов E, G из второго файла

так, что ли?  
 
 
 
#3
08.04.2021 08:21:17
Почти)
Провести сравнение по столбцу А (файл 1 и 2), далее найденные совпадения перенести в файл 3 (столбец А) и по нему перенести данные из  B и С (файл 1) и столбцы D,E (НО! Данные в D это данные из файла 2 столбец С (т.к в файлах шапки разные и нужная информация находится в другом столбце), а в E данные из G файла 2.

Всего получается 3 файла.
1 - это основные данные
2 - это дополнительные данные
3 - содержит только необходимые данные из 1 и 2

Постарался максимально ясно расписать. Так же прилагаю инфографику.
Т.е в процессе работы постоянно приходится искать значение столбца А файла 1 в столбце А файла 2 и при выявлении совпадения, переносить остальные данные из строки, где это совпадение найдено, но только по определенным столбцам(как описано и показано выше).
 
 
 
#4
08.04.2021 10:08:42
Тут нужно либо на массивах делать с использованием словаря, для проверки вхождения, либо на коллекциях с модулями классов, в любом случае задача не из простых
Если файлы имеют большие таблицы + формулы, то вариант сверки прямо на листах будет просаживаться по скорости выполнения.
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#5
08.04.2021 10:58:25
Формул нет. Просто выгрузка данных, вот и прошу помощи т.к работа очень рутинная, а сам не смогу написать необходимый скрипт.
Скрипт, что я приложил, примерно выполняет необходимое, но он работает только в одной книге с таблицами и копирует данные не совсем те, что требуются.
 
 
 
#6
08.04.2021 11:51:02
Код
Const name1 = "Book1.xlsx"
Const name2 = "Book2.xlsx"

Sub BookBook()
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    
    On Error Resume Next
    Set wb1 = Workbooks(name1)
    Set wb2 = Workbooks(name2)
    On Error GoTo 0
    If wb1 Is Nothing Then
        MsgBox "Не найден файл " & name1, vbExclamation
        Exit Sub
    End If
    If wb1 Is Nothing Then
        MsgBox "Не найден файл " & name2, vbExclamation
        Exit Sub
    End If
    
    Dim y As Long
    Dim u As Long
    Dim dicY As Object
    Set dicY = CreateObject("Scripting.Dictionary")
    Dim ar1 As Variant
    Dim ar2 As Variant
    With wb1.Sheets(1)
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        ar1 = .Range(.Cells(1, 1), .Cells(y, [G1].Column))
    End With
    With wb2.Sheets(1)
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        ar2 = .Range(.Cells(1, 1), .Cells(y, [G1].Column))
    End With
    For y = 2 To UBound(ar1, 1)
        dicY.Item(CStr(ar1(y, 1))) = y
        ar1(y, 4) = Empty
        ar1(y, 5) = Empty
    Next
    For y = 2 To UBound(ar2, 1)
        If dicY.Exists(CStr(ar1(y, 1))) Then
            u = dicY.Item(CStr(ar1(y, 1)))
            ar1(u, 4) = ar2(y, 3)
            ar1(u, 5) = ar2(y, 7)
        End If
    Next
    
    
    Dim wb3 As Workbook
    Set wb3 = Workbooks.Add(1)
    wb3.Sheets(1).Cells(1, 1).Resize(UBound(ar1, 1), UBound(ar1, 2)) = ar1
End Sub
А сообщение в порядок приведите.
Изменено: МатросНаЗебре - 08.04.2021 11:52:20
 
 
 
#7
08.04.2021 12:38:48
МатросНаЗебре, спасибо большое! Делает практически все как нужно, единственное он не делает сравнение по столбцу А между книгами, а просто копирует из первой книги столбец, соответственно и остальные данные он тоже просто копирует столбцами.

А должен сравнивать столбец А, при нахождении совпадений копировать значение и соответствующие ему значения из других столбцов т.к данные могут быть не упорядочены или в какой-то книге пропущен ID... Например он скопирует данные из A книги 1, относящиеся к ID 9, но в книге 2 на месте ID 9 будет, допустим, ID 5.
Получается он по ID данные не соотносит.
 
 
 
#8
08.04.2021 12:47:40
Закралась опечатка.
Код
'2
Const name1 = "Book1.xlsx"
Const name2 = "Book2.xlsx"
 
Sub BookBook()
    Dim wb1 As Workbook
    Dim wb2 As Workbook
     
    On Error Resume Next
    Set wb1 = Workbooks(name1)
    Set wb2 = Workbooks(name2)
    On Error GoTo 0
    If wb1 Is Nothing Then
        MsgBox "Не найден файл " & name1, vbExclamation
        Exit Sub
    End If
    If wb1 Is Nothing Then
        MsgBox "Не найден файл " & name2, vbExclamation
        Exit Sub
    End If
     
    Dim y As Long
    Dim u As Long
    Dim dicY As Object
    Set dicY = CreateObject("Scripting.Dictionary")
    Dim ar1 As Variant
    Dim ar2 As Variant
    With wb1.Sheets(1)
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        ar1 = .Range(.Cells(1, 1), .Cells(y, [G1].Column))
    End With
    With wb2.Sheets(1)
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        ar2 = .Range(.Cells(1, 1), .Cells(y, [G1].Column))
    End With
    For y = 2 To UBound(ar1, 1)
        dicY.Item(CStr(ar1(y, 1))) = y
        ar1(y, 4) = Empty
        ar1(y, 5) = Empty
    Next
    For y = 2 To UBound(ar2, 1)
        If dicY.Exists(CStr(ar2(y, 1))) Then
            u = dicY.Item(CStr(ar2(y, 1)))
            ar1(u, 4) = ar2(y, 3)
            ar1(u, 5) = ar2(y, 7)
        End If
    Next
     
    Dim wb3 As Workbook
    Set wb3 = Workbooks.Add(1)
    wb3.Sheets(1).Cells(1, 1).Resize(UBound(ar1, 1), UBound(ar1, 2)) = ar1
End Sub
 
 
 
#9
08.04.2021 13:51:52
МатросНаЗебре, огромное спасибо! Все работает как часы!
 
 
 
Страницы: 1
Наверх