如果其他列值匹配，则VBA Set Columns相等

我有两个Excel工作表。 如果这两个电子表格的唯一ID列相匹配，那么我想将表1中列C的值复制到表2中的H列中。表1中的唯一ID列是Q，表2是F.下面的代码匹配工作表之间的ID和删除工作表1中没有匹配表2中的行。我试图修改此代码中的循环，以实现我所需要的。

我相信THEN之后的那一行是所有需要修改的，然后删除删除行的最后一段代码。 我可能是错的。

Sub Compare() Dim ws1 As Worksheet, ws2 As Worksheet Dim c As Range, rng As Range Dim lnLastRow1 As Long, lnLastRow2 As Long Dim lnTopRow1 As Long, lnTopRow2 As Long Dim lnCols As Long, i As Long Set ws1 = ThisWorkbook.Sheets("Sheet1") Set ws2 = ThisWorkbook.Sheets("Sheet2") ' Duplicate Sheet 1 Worksheets("Sheet1").Activate Sheets("Sheet1").Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = "RAW DATA" DoEvents Worksheets("Sheet1").Activate lnTopRow1 = 2 'first row containing data in ws1 lnTopRow2 = 2 'first row containing data in ws2 'Find last cells containing data: lnLastRow1 = ws1.Range("Q:Q").Find("*", Range("Q1"), LookIn:=xlValues, searchdirection:=xlPrevious).Row lnLastRow2 = ws2.Range("F:F").Find("*", Range("F1"), LookIn:=xlValues, searchdirection:=xlPrevious).Row Set rng = ws2.Range("F" & lnTopRow2 & ":F" & lnLastRow2) lnCols = ws1.Columns.Count ws1.Columns(lnCols).Clear 'Using the very right-hand column of the sheet For i = lnLastRow1 To lnTopRow1 Step -1 For Each c In rng If ws1.Range("Q" & i).Value = c.Value Then ws1.Cells(i, lnCols).Value = "KEEP" ' Add tag to right-hand column of sheet if match found Exit For End If Next c Next i ' Delete rows where the right-hand column of the sheet is blank Set rng = ws1.Range(Cells(lnTopRow1, lnCols), Cells(lnLastRow1, lnCols)) rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete ws1.Columns(lnCols).Clear End Sub 

Answer 1

用VBA应用工作表的MATCH函数replace内部嵌套循环可能会更好。 如果使用联合方法构build非连续范围的单元格/行，并同时传输与您相匹配的行的值，则应该获得可观的速度提升。

 Option Explicit Sub CompareXferDelete() Dim ws1 As Worksheet, ws2 As Worksheet Dim delrng As Range Dim lnTopRow1 As Long, lnLastRow1 As Long Dim mrw As Variant, i As Long Set ws1 = ThisWorkbook.Sheets("Sheet1") Set ws2 = ThisWorkbook.Sheets("Sheet2") With ws1 ' Duplicate Sheet 1 .Copy After:=.Parent.Sheets(.Parent.Sheets.Count) .Parent.Sheets(.Parent.Sheets.Count).Name = "RAW DATA" & .Parent.Sheets.Count 'first row containing data in ws1 lnTopRow1 = 2 'Find last cells containing data: lnLastRow1 = .Range("Q:Q").Find("*", .Range("Q1"), LookIn:=xlValues, searchdirection:=xlPrevious).Row 'seed the rows to delete so it doesn't have to be checked each time it is unioned Set delrng = .Range("Q" & lnLastRow1 + 1) For i = lnLastRow1 To lnTopRow1 Step -1 mrw = Application.Match(.Cells(i, "Q").Value2, ws2.Columns("F"), 0) If Not IsError(mrw) Then 'exists in Sheet2 - transfer value from ws1.C to ws2.H ws2.Cells(mrw, "H") = .Cells(i, "C").Value2 Else 'does not exist in Sheet2 - add to delete list Set delrng = Union(delrng, .Cells(i, "Q")) End If Next i ' Delete the rows collected into the union delrng.EntireRow.Delete 'reactivate Sheet1 (unnecessary for code operation; simplifies things for user) .Activate End With End Sub 

Answer 2

replaceFOR循环：

  For i = lnLastRow1 To lnTopRow1 Step -1 For Each c In rng If ws1.Range("Q" & i).Value = c.Value Then ' ws1.Cells(i, lnCols).Value = "KEEP" ' Add tag to right-hand column of sheet if match found Dim valueToCopy As String valueToCopy = ws1.Range("C" & i).Value Worksheets("Sheet2").Activate Range("H" & c.Row).Value = valueToCopy Worksheets("Sheet1").Activate Exit For End If Next c Next i 

这现在应该工作。 无论如何，我更喜欢其他build议！