VBA Excel删除一张纸独有的项目 [英] VBA Excel remove Items unique to one sheet

问题描述

我正在处理一个较长的应用程序，我碰壁试图在两张纸之间找到唯一的记录，如果第二张纸中不存在该记录，则从第一张纸中删除该行.这是我程序部分的代码，我对如何完成此操作感到有些困惑，希望有人愿意看看并给我一些建议，谢谢.*解释:我正在寻找B列中的唯一记录，并且我将在该列中搜索3000多个单元格.如果记录存在于工作表1中，但不存在于工作表2中，则应将其删除.

I'm working on a long application and I hit a wall trying to find unique records between 2 sheets and removing the row from the first sheet if the record doesn't exist in the second sheet. Here's the code I have for this section of my program, I'm a bit confuse as to how to accomplish this and I'm hoping someone will be willing to take a look and give me some suggestions, thanks. *Explanation: I'm looking for the unique records in column B and I'll be searching over 3000 cells in that column. If the records exist in sheet 1 but not in sheet 2 they should be deleted.

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

推荐答案

此函数基于主键比较具有相同列的2个数据表.它将以橙色突出显示不匹配的行，并在行匹配的地方发现字段值的任何差异，并突出显示红色并创建注释以显示不匹配的值(您可以随时删除此功能)

This function compares 2 data sheets with the same columns based on a primary key. It will highlight non-matched rows in orange and where the rows do match it will find any differences in the field values and highlight red and create a comment to show mismatched value (you can always removed this functionality)

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

Just pass in the 2 sheet names, the primary key col and whether data has col headers.

例如strResult = CompareDataSheets("Sheet1"，"Sheet2"，1，True)

eg. strResult=CompareDataSheets("Sheet1","Sheet2",1,True)

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 =错误:"&错误说明

Err: CompareDataSheets = "Error: " & Err.Description

结束功能

这篇关于VBA Excel删除一张纸独有的项目的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！