Question

我正在处理一个很长的应用程序，如果第二张表中不存在记录，我试图找到两张纸之间的唯一记录并从第一张纸上删除该行。这是我的程序的这一部分的代码，我有点混淆如何实现这一点，我希望有人愿意看一看并给我一些建议，谢谢。 *说明：我正在寻找B列中的独特记录，我将在该列中搜索超过3000个单元格。如果记录存在于表1中但不存在于表2中，则应删除它们。

Option Explicit

Sub RemoveReversionItems()
Dim wbook As Workbook, Wsheet As Worksheet, wbName As String, wsName As String
Dim AlphaRange As Range, ReversionRange As Range
Dim AlphaArray
Dim ReversionArray
Dim x As Long
Dim AlphaSheetColumn As String: AlphaSheetColumn = "B" 'The column with the PO#
Dim ReversionSheetColumn As String: ReversionSheetColumn = "B" 'The column with the PO#


For Each wbook In Workbooks
If wbook.Name <> ActiveWorkbook.Name Then wbName = wbook.Name
Workbooks(wbName).Activate

'********************************
'    Look for Reversion Queue
'********************************

For Each Wsheet In wbook.Worksheets
    wsName = Wsheet.Name
    If Wsheet.Name Like "Revers*" Then
    MsgBox "This workbook is named " & wbName & " The Sheet is " & wsName
    'Get Reversion Range
    With Sheets(wsName)
        Set ReversionRange = .Range(.Range(ReversionSheetColumn & "2"), _
                .Range(ReversionSheetColumn & rows.Count).End(xlUp))
        ReversionArray = ReversionRange
    End With
    End If
Next Wsheet


'*****************************
'    Look for Alpha Queue
'*****************************

For Each Wsheet In wbook.Worksheets
    wsName = Wsheet.Name
    If Wsheet.Name Like "PO_LN*" Then
        'Load Alpha WorkSheet array
    With Sheets(wsName)
        Set AlphaRange = .Range(.Range(AlphaSheetColumn & "2"), _
                .Range(AlphaSheetColumn & rows.Count).End(xlUp))
        AlphaArray = AlphaRange
    End With

    MsgBox "This workbook is named " & wbName & " The Sheet is " & wsName
    End If
Next Wsheet

    If IsArray(ReversionArray) Then
        For x = UBound(ReversionArray) To 1 Step -1
            If AlphaArray <> ReversionArray(x, 2) Then
            ReversionRange.Cells(x).EntireRow.Interior.Color = 255   'Newtest

            End If
        Next
    Else
    End If
Next wbook


End Sub

Answer 1

此功能根据主键比较2个数据表和相同的列。它将突出显示橙色中不匹配的行以及行匹配的位置，它将在字段值中找到任何差异并突出显示红色并创建注释以显示不匹配的值（您始终可以删除此功能）

只需传递2个工作表名称，主键col以及数据是否具有col标头。

例如。 strResult = CompareDataSheets（ “Sheet 1中”， “Sheet 2中”，1，真）

Function CompareDataSheets(ByVal sht1 As String, ByVal sht2 As String, ByVal pkCol As Integer, ByVal hasHeaders As Boolean) As String

Dim ws1, ws2 As Worksheet
Dim x As Integer
Dim nmSht1, nmSht2, colDiffs, colName As String
Dim strIdentifier As String
Dim vmatch As Variant

Set ws1 = ActiveWorkbook.Sheets(sht1)
Set ws2 = ActiveWorkbook.Sheets(sht2)

On Error GoTo Err

If hasHeaders Then x = 2 Else x = 1

'Find Non Matches in sheet1
Do Until ws1.Cells(x, pkCol).Value = ""
    vmatch = Application.Match(ws1.Cells(x, pkCol).Value, ws2.Columns(pkCol), 0)
    If IsError(vmatch) Then
        ws1.Rows(x).Interior.Color = 49407
    Else
        'Find Matched PK Column diffs
        iCol = 1
        Do Until ws1.Cells(1, iCol).Value = ""

            If ws1.Cells(x, iCol).Value <> ws2.Cells(x, iCol).Value Then
                If hasHeaders Then
                    colName = ws1.Cells(1, iCol).Value
                Else
                    colName = iCol
                End If

                With ws1.Cells(x, iCol)
                .Interior.Color = 5263615
                .ClearComments
                .AddComment sht2 & " Value=" & ws2.Cells(x, iCol).Value
                End With

                If ws2.Cells(x, iCol).Value <> "" Then
                    With ws2.Cells(x, iCol)
                    .Interior.Color = 5263615
                    .ClearComments
                    .AddComment sht1 & " Value=" & ws1.Cells(x, iCol).Value
                    End With
                End If

            End If
            iCol = iCol + 1
        Loop
    End If
    x = x + 1

Loop

If Len(nmSht1) > 0 Then nmSht1 = Left(nmSht1, Len(nmSht1) - 1)

If hasHeaders Then x = 2 Else x = 1

'Find Non Matches in sheet2
Do Until ws2.Cells(x, pkCol).Value = ""
   vmatch = Application.Match(ws1.Cells(x, pkCol).Value, ws2.Columns(pkCol), 0)
    If IsError(vmatch) Then
       ws2.Rows(x).Interior.Color = 49407
    End If
     x = x + 1
Loop

If Len(nmSht2) > 0 Then nmSht2 = Left(nmSht2, Len(nmSht2) - 1)

CompareDataSheets = "Done!"

Exit Function

错误： CompareDataSheets =“错误：”＆amp; Err.Description

结束功能

VBA Excel删除一个工作表唯一的项目

1 个答案: