目标:从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
已编译但未测试:
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