VBA: 检查第一个 sheet 列 a 的值是否存在于第二个移位列 A 中。如果是，则复制整行

Question

我是 VBA 的新人，实际上不知道如何处理该任务。也许你能帮帮我。

我在两个 sheet 中有两个 table。 Table 来自 sheet 1 每日更新。

我需要做的是检查 A 列 (sheet 1) 中的任何值是否在 A 列 (sheet 2) 中。如果是，则什么也不做。如果不是，则将整行复制到 sheet 中的 table 2.

根据 google 结果，我开始写一些代码，但我卡住了。

    Dim source            As Worksheet
    Dim finaltbl          As Worksheet
    Dim rngsource         As Range
    Dim rngfinaltbl       As Range


    'Set Workbook
    Set source = ThisWorkbook.Worksheets("Sheet 1")
    Set finaltbl = ThisWorkbook.Worksheets("Sheet 2")

    'Set Column
    Set rngsource = source.Columns("A")
    Set rngfinaltbl = finaltbl.Columns("A")

我假设接下来我需要编写一些循环，但我真的不知道它是如何工作的。

Answer 1

不，你不需要循环。您需要范围的查找功能参见 Documentation for Find Method (Excel) 还有 Excel VBA Find A Complete Guide

Answer 2

更新缺少（唯一）行的工作表（字典）

调整常量部分中的值。

Sub UpdateData()
    
    ' Source
    Const sName As String = "Sheet1"
    Const sFirstCellAddress As String = "A2"
    ' Destination
    Const dName As String = "Sheet2"
    Const dFirstCellAddress As String = "A2"
        
    ' Reference the destination worksheet.
    Dim dws As Worksheet: Set dws = ThisWorkbook.Worksheets(dName)
    
    Dim drg As Range
    Dim dCell As Range
    Dim drCount As Long
    
    ' Reference the destination data range.
    With dws.Range(dFirstCellAddress)
        Set dCell = .Resize(dws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If dCell Is Nothing Then Exit Sub ' no data in column range
        drCount = dCell.Row - .Row + 1
        Set drg = .Resize(drCount)
    End With
    
    Dim Data As Variant
    
    ' Write the values from the destination range to an array.
    If drCount = 1 Then
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = drg.Value
    Else
        Data = drg.Value
    End If
    
    ' Write the unique values from the array to a dictionary.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim Key As Variant
    Dim dr As Long
    
    For dr = 1 To drCount
        Key = Data(dr, 1)
        If Not IsError(Key) Then ' exclude errors
            If Len(Key) > 0 Then ' exclude blanks
                dict(Key) = Empty
            End If
        End If
    Next dr
    
    ' Reference the source worksheet.
    Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets(sName)
    
    Dim srg As Range
    Dim sCell As Range
    Dim srCount As Long
    
    ' Reference the source data range.
    With sws.Range(sFirstCellAddress)
        Set sCell = .Resize(sws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If sCell Is Nothing Then Exit Sub ' no data in column range
        srCount = sCell.Row - .Row + 1
        Set srg = .Resize(srCount)
    End With
        
    ' Write the values from the source range to an array.
    If srCount = 1 Then
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = srg.Value
    Else
        Data = srg.Value
    End If
        
    Dim surg As Range
    Dim sr As Long
    
    ' Loop through the source values...
    For sr = 1 To srCount
        Key = Data(sr, 1)
        If Not IsError(Key) Then ' exclude errors
            If Len(Key) > 0 Then ' exclude blanks
                If Not dict.Exists(Key) Then ' if source value doesn't exist...
                    dict(Key) = Empty ' ... add it (to the dictionary)...
                    If surg Is Nothing Then ' and combine the cell into a range.
                        Set surg = srg.Cells(sr)
                    Else
                        Set surg = Union(surg, srg.Cells(sr))
                    End If
                End If
            End If
        End If
    Next sr
        
    ' Copy all source rows in one go below ('.Offset(1)') the last cell.
    If Not surg Is Nothing Then
        surg.EntireRow.Copy dCell.Offset(1).EntireRow
    End If
    
    MsgBox "Data updated.", vbInformation

End Sub

VBA: 检查第一个 sheet 列 a 的值是否存在于第二个移位列 A 中。如果是，则复制整行

VBA: Check if value from first sheet column a exists in second shift column A. If yes, then copy whole row

vba

loops

更新缺少（唯一）行的工作表（字典）