Сравните все данные между 2 листами, напечатайте заголовок и ключ на новом листе - PullRequest
Новая
       80

Сравните все данные между 2 листами, напечатайте заголовок и ключ на новом листе

0 голосов
/ 28 мая 2020

Цель: найти совпадение первичного ключа из NuMAP на листе DL. Если он не найден, распечатайте первичный ключ из столбца NuMAP A на листе ошибок. Если он найден, l oop по всем ячейкам в этой строке, сравнивая данные между двумя листами (DL, NuMAP). Если данные на листе NuMAP не совпадают с данными на листе DL для данного (ключа, столбца), то распечатайте столбец и ключ на новом листе.

Структура данных: в первом столбце обоих листов находится первичный ключ. Столбцы на двух листах расположены одинаково, а строки - нет. Между листами могло быть разное количество строк.

ПРОБЛЕМА: база кода - от , здесь . Он правильно просматривает листы, но я не уверен, как изменить его, чтобы скопировать заголовок и ключ и поместить их на новый лист. Я старался догадаться, как это сделать, но мне очень нужна помощь. 

Sub DetectChanges()
    Dim DL As Worksheet, NuMAP As Worksheet '<-- explicitly declare each variable type
    Dim DLData, ErrorShtrng As Range, f As Range, cell As Range
    Dim icol, lastrow As Long
    Dim ErrorSht

    Set DL = Worksheets("Account_Master_DL").columns(1).SpecialCells(xlCellTypeConstants) '<-- set a range with DL cells containing data
    Set ErrorSht = Worksheets("Acct_master_Error")
    lastrow = ErrorSht.Cells(Rows.Count, "A").End(xlUp).Row
    Set ErrorShtrng = ErrorSht.Range("A" & lastrow)


    With Worksheets("Account_Master_NuMAP") '<--| reference NuMAP
        For Each cell In Intersect(.UsedRange, .columns(1)).SpecialCells(xlCellTypeConstants) '<-_| loop through its column "A" non blank cells
            Set f = DLData.Find(what:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole) '<--| search for current cell value in DL data
            If f Is Nothing Then '<--| if not found then...
                Intersect(cell.EntireRow, .UsedRange).Address.Copy ErrorShtrng '<--| copy primary key from column A into Errorsht Col A next open row, put "All" in Col B
            Else
                For icol = 1 To .Range(cell, .Cells(cell.Row, .columns.Count).End(xlToLeft)).columns.Count - 1 '<--| loop through NuMAP current cell row
                    If f.Offset(, icol) <> cell.Offset(, icol) Then '<--| if it doesn't match corresponding cell in DL
                        cell.Offset(, icol).Copy ErrorShtrng '<--| copy primary key in Column A, Header of column to ErrorSht columns A, B

                    End If
                Next icol
            End If
        Next cell
    End With
End Sub

1 Ответ

0 голосов
/ 28 мая 2020

Скомпилировано, но не проверено: 

Sub DetectChanges()

    Dim ErrorShtrng As Range, f As Range, cell As Range, icol As Long
    Dim wsError As Worksheet, wsDL As Worksheet, wsNuMAP As Worksheet

    Set wsError = ThisWorkbook.Worksheets("Acct_master_Error")
    Set wsDL = ThisWorkbook.Worksheets("Account_Master_DL")
    Set wsNuMAP = Worksheets("Account_Master_NuMAP")

    Set ErrorShtrng = wsError.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) '<< next empty row

    With wsNuMAP
        For Each cell In Intersect(.UsedRange, .Columns(1)).SpecialCells(xlCellTypeConstants)
            Set f = wsDL.Columns(1).Find(what:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
            If f Is Nothing Then
                Intersect(cell.EntireRow, .UsedRange).Copy ErrorShtrng
                Set ErrorShtrng = ErrorShtrng.Offset(1, 0) 'next row
            Else
                For icol = 1 To .Range(cell, .Cells(cell.Row, .Columns.Count).End(xlToLeft)).Columns.Count - 1
                    If f.Offset(, icol) <> cell.Offset(, icol) Then
                        ErrorShtrng.Value = cell.Value
                        ErrorShtrng.Offset(0, 1).Value = cell.Offset(, icol).EntireColumn.Cells(2).Value 'if headers in row2
                        Set ErrorShtrng = ErrorShtrng.Offset(1, 0)
                    End If
                Next icol
            End If
        Next cell
    End With
End Sub
...