VBA删除匹配数据的行

Posted 2023-03-27

【中文标题】VBA删除匹配数据的行

【英文标题】：VBA Delete rows of matching data

【发布时间】：2015-05-11 05:49:01

【问题描述】：

我构建了一个宏，它在表 1 和表 2 上传输 2 个 csv 数据文件并重命名这 2 个表。我想构建另一个宏，它将两组数据之间的所有不匹配行复制到一个新的 xlsx 文件中。为了识别匹配的数据，我需要写一些东西来做到这一点：

如果 sheet1 中 A 列的单元格值在 sheet2 的 A 列中有匹配值，那么我需要比较每张表上的相应行： sheet1 的 B 列到 sheet2 的 C 列，sheet1 的 D 列到sheet2的E列，sheet1的F列到sheet2的G列，sheet1的G列到sheet2的H列，sheet1的H列到sheet2的I列，sheet1的J列到sheet2的J列，并复制所有行数据将 sheet1 中与 sheet2 中不匹配的行放入新文件中。

这是我的代码草稿：

Sub SupprLignes()
Dim rowCount1 As Long, rowCount2 As Long
Dim rng1 As Range, rng2 As Range, MyCell As Range, Mycell2 As Range
Dim currentRow As Long
Dim WB As Workbook
Dim WS As Worksheet

Set WB = Workbooks.Add

ActiveWorkbook.SaveAs "C:\Users\Phil\Desktop _
\Report_" & Format(Date, "dd-mm-yyyy") & ".xlsx"

rowCount1 = Workbooks("Received_temp.xlsx").Worksheets _
("Received").Range("A2").SpecialCells(xlCellTypeLastCell).Row

Set rng1 = Workbooks("Received_temp.xlsx").Worksheets _
("Received").Range("A2:A" & rowCount1)

rowCount2 = Workbooks("Received_temp.xlsx").Worksheets _
("NotReceived").Range("A2").SpecialCells(xlCellTypeLastCell).Row
Set rng2 = Workbooks("Received.xlsx").Worksheets _
("NotReceived").Range("A2:A" & rowCount2)

Dim sheet1() As Variant
ReDim sheet1(rowCount1 - 1, 2)

currentRow = 0

For Each MyCell In rng1.Cells
    For Each Mycell2 In rng2.Cells
        If Mycell2.Value = MyCell.Value And Mycell2.Offset(0, 5).Value = _
MyCell.Offset(0, 5).Value And Mycell2.Offset(0, 2).Value = _
MyCell.Offset(0, 2).Value Then

            Workbooks("Received_temp.xlsx").Worksheets _
("Received").Rows(Cell.Row).Copy
                Destination:=Workbooks("Received.xlsx").Worksheets _
("Received").Range("A" & currentRow)

            currentRow = currentRow + 1

            GoTo NextIteration
        End If
    Next cell2
Next Cell

NextIteration:
ThisWorkbook.Sheets(1).Rows(Cell.Row).Copy Destination:=ThisWorkbook.Sheets(4).Range("A" & currentRow)

End Sub

我知道 For Next 是错误的，但我知道我的方向不对，所以我暂时就这样吧。

【问题讨论】：

您的代码做了哪些不该做的事情，或者没有做您希望它做的事情？乍一看，我认为 For Each... Next 循环不一定是解决此问题的错误方法；我有一个问题的地方是关于 GoTo NextIteration。如果您将其替换为 Exit For，则与 Rng2 中的所有内容相比，您将停止查看 Rng1 中的“this”单元格，并继续查看 Rng1 中的其余单元格。看看这是否对您有好处，并让我们知道事情偏离了您想要的方向。

无论如何，您应该将Next cell2 和Next Cell 替换为Next。

【参考方案1】：

首先，在工作表中添加一列并插入匹配函数。这将告诉您相应搜索值的行号。不匹配的行将显示#N/A。您可以通过使用宏记录器以 RC 格式保存公式来自动填充匹配列，然后将它们复制到工作表的底部。

现在在匹配行列中循环查找#N/A

例子：

Dim aCell as range
Dim aRange as range
dim tWS as worksheet
dim lrow as long

Application.calculation = xlmanual
set tWS = thisworkbook.sheets("Sheet2")  '*** Target worksheet to copy not founds

set arange = intersect(activesheet.range("A1"), activesheet.usedrange)
for each acell in arange
   if isnull(acell) then
     lrow = tws.range("A65536").end(xlup).row + 1
    copy acell.entirerow tws.range("A" & Lrow)
   endif
next acell
application.calculation = xlAutomatic

完成后，您可以将 TWS 复制到另一个工作簿，这比链接到新工作簿并一次附加一条记录更容易。