VBA他の列の値が一致する場合、列は同じに設定されます

Question

2つの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

内部ネストされたループをワークシートのMATCH functionのVBAアプリケーションに置き換える方がよい場合があります。 Union methodで削除するセル/行の連続しない範囲を構築しているときに、一致する行の値を同時に転送すると、かなりのスピードで報酬を受け取る必要があります。

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

ので、FORループを交換してください：

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 

これが機能するようになりました。私は他の提案をとにかく好む！