比较两张纸之间的所有数据，打印页眉和新纸上的键

Question

目标：从DL表格上的NuMAP查找主键匹配。如果找不到，请从NuMAP列A上将主键打印到错误表上。如果找到，循环遍历该行中的所有单元格，比较2张纸（DL，NuMAP）之间的数据。如果NuMAP表上的数据与给定（键，列）的DL表上的数据不相等，则在新表上打印列和键。

数据结构：两张纸的第一栏中都有一个主键。两张纸之间的列顺序相同，但行的顺序不相同。图纸之间可能有不同数量的行。

问题：代码的基础来自here。它正确地循环通过工作表，但是我不确定如何更改它以复制标题和键并将其放在新工作表上。我对如何做到最好，但希望能有所帮助。

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

Answer 1

已编译但未测试：

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