求助各位老师，如何用VBA进行两表间A列重复数据匹配，并将所在行整行提取

lin20201115

1.将工作表"待匹配"中，A列重复的数值所在行整行提取至结果工作表
2.将工作表"待匹配"A列的数值与工作表"总数据"A列的数值进行对比查重
如果工作表"总数居"A列数值与工作表"待匹配"A列数值相同，则提取工作表“总数据”A列重复的数值所在行整行提取至结果工作表

即:
其中以工作表"待匹配"数据为主，
如果工作表"待匹配"A列有重复的值，则将工作表"待匹配"A列有重复值的所在行整行提取至结果
如果工作表"总数据"A列有重复的值，但是工作表"待匹配"A列中没有，则不提取
如果工作表"总数据"A列有重复的值，且工作表"待匹配"A列中有，则将工作表"总数据"A列有重复值的所在行整行提取至结果



各表情况如下
工作表"待匹配" 有几千行数据，列数为8列，A列数值不为空，其他列存在空值
工作表"总数据" 有几万行数据，列数为8列，A列数值不为空，其他列存在空值


页面布局如图所示：


文件见附件： 数据匹配.zip (11.9 KB, 下载次数: 10)

2023-2-10 22:11 上传

点击文件名下载附件

Jday1218

Sub ExtractDuplicates()
    Dim wsMatch As Worksheet
    Dim wsData As Worksheet
    Dim wsResult As Worksheet
    Dim lastRowMatch As Long
    Dim lastRowData As Long
    Dim i As Long
    Dim j As Long
    Dim dict As Object
    Dim arrMatch() As Variant
    Dim arrData() As Variant
    Dim arrResult() As Variant
    Dim count As Long
   
    Set dict = CreateObject("Scripting.Dictionary")
    Set wsMatch = ThisWorkbook.Sheets("待匹配")
    Set wsData = ThisWorkbook.Sheets("总数据")
    Set wsResult = ThisWorkbook.Sheets.Add
    wsResult.Name = "结果"
   
    lastRowMatch = wsMatch.Cells(wsMatch.Rows.Count, "A").End(xlUp).Row
    lastRowData = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
   
    arrMatch = wsMatch.Range("A1:H" & lastRowMatch).Value
    arrData = wsData.Range("A1:H" & lastRowData).Value
    ReDim arrResult(1 To lastRowMatch + lastRowData, 1 To 8)
   
    count = 1
    For i = 1 To lastRowMatch
        If dict.Exists(arrMatch(i, 1)) Then
            For j = dict(arrMatch(i, 1)) To i
                arrResult(count, 1) = arrMatch(j, 1)
                arrResult(count, 2) = arrMatch(j, 2)
                arrResult(count, 3) = arrMatch(j, 3)
                arrResult(count, 4) = arrMatch(j, 4)
                arrResult(count, 5) = arrMatch(j, 5)
                arrResult(count, 6) = arrMatch(j, 6)
                arrResult(count, 7) = arrMatch(j, 7)
                arrResult(count, 8) = arrMatch(j, 8)
                count = count + 1
            Next j
        End If
        dict(arrMatch(i, 1)) = i
    Next i
   
    For i = 1 To lastRowData
        If dict.Exists(arrData(i, 1)) Then
            For j = dict(arrData(i, 1)) To lastRowMatch
                If arrMatch(j, 1) = arrData(i, 1) Then
                    arrResult(count, 1) = arrData(i, 1)
                    arrResult(count, 2) = arrData(i, 2)
                    arrResult(count, 3) = arrData(i, 3)
                    arrResult(count, 4) = arrData(i, 4)
                    arrResult(count, 5) = arrData(i, 5)
                    arrResult(count, 6) = arrData(i, 6)
                    arrResult(count, 7) = = arrData(i, 7)
                    arrResult(count, 8) = arrData(i, 8)
                    count = count + 1
                        End If
                  Next j
           End If
            Next i
wsResult.Range("A1:H" & count - 1).Value = arrResult

lin20201115

Jday1218 发表于 2023-2-11 01:51
Sub ExtractDuplicates()
    Dim wsMatch As Worksheet
    Dim wsData As Worksheet

感谢答疑解惑

lin20201115

Jday1218 发表于 2023-2-11 01:51
Sub ExtractDuplicates()
    Dim wsMatch As Worksheet
    Dim wsData As Worksheet

不好意思，怪我问题没描述清楚。
如果工作表"总数据"A列有重复的值，且工作表"待匹配"A列中有，则将工作表"总数据"A列有重复值的所在行整行提取，将工作表"待匹配"A列重复值的所在行整行提取
方便帮忙修改下么

3190496160

Sub 匹配()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("总数据")
    ar = .[a1].CurrentRegion
End With
With Sheets("待匹配")
    br = .[a1].CurrentRegion
End With
ReDim arr(1 To UBound(ar) + UBound(br), 1 To 8)
For i = 2 To UBound(br)
    If Trim(br(i, 1)) <> "" Then
        If Not d.exists(Trim(br(i, 1))) Then
            d(Trim(br(i, 1))) = i
        Else
           d(Trim(br(i, 1))) = d(Trim(br(i, 1))) & "|" & i
        End If
    End If
Next i
For Each k In d.keys
    m = 0
    ReDim brr(1 To UBound(ar), 1 To UBound(ar, 2))
    For i = 2 To UBound(ar)
        If Trim(ar(i, 1)) = k Then
            m = m + 1
            For j = 1 To UBound(ar, 2)
                brr(m, j) = ar(i, j)
            Next j
        End If
    Next i
    If m > 0 Then
        rr = Split(d(k), "|")
        For s = 0 To UBound(rr)
            xh = rr(s)
            n = n + 1
            For j = 1 To UBound(br, 2)
                arr(n, j) = br(xh, j)
            Next j
        Next s
        For i = 1 To m
            n = n + 1
            For j = 1 To UBound(brr, 2)
                arr(n, j) = brr(i, j)
            Next j
        Next i
    End If
Next k
With Sheets("结果")
    .[a1].CurrentRegion.Offset(1) = Empty
    If n <> "" Then .[a2].Resize(n, UBound(arr, 2)) = arr
End With
Set d = Nothing
Application.ScreenUpdating = False
MsgBox "ok!"
End Sub

3190496160

数据匹配.rar (25.51 KB, 下载次数: 17)

2023-2-11 11:36 上传

点击文件名下载附件

3190496160

模拟结果与描述不一致，代码仅供参考
说实话，楼主的表达能力实在是该提高

准提部林

1) 工作表"总数据"A列只有一筆，工作表"待匹配"A列也只有一筆, 提取否???
2) 工作表"总数据"A列有重复，工作表"待匹配"A列也有，
   则将工作表"总数据"A列有重复值行整行提取, 但不提取"待匹配"???


   

lin20201115

3190496160 发表于 2023-2-11 11:37
模拟结果与描述不一致，代码仅供参考
说实话，楼主的表达能力实在是该提高

额，昨晚编辑的时候，也绕的晕晕的。
其中以工作表"待匹配"数据为主，
如果工作表"待匹配"A列有重复的值，则将工作表"待匹配"A列有重复值的所在行整行提取至结果
如果工作表"总数据"A列有重复的值，但是工作表"待匹配"A列中没有，则不提取
如果工作表"总数据"A列有重复的值，且工作表"待匹配"A列中有，则将工作表"总数据"A列有重复值的所在行整行提取至结果
如果工作表"总数据"A列有重复的值，且工作表"待匹配"A列中有，则将工作表"总数据"A列有重复值的所在行整行提取，将工作表"待匹配"A列重复值的所在行整行提取

lin20201115

3190496160 发表于 2023-2-11 11:37
模拟结果与描述不一致，代码仅供参考
说实话，楼主的表达能力实在是该提高

就是想提取A列中重复值。
待匹配工作表中A列有重复的提取
总数据工作表中A列与待匹配工作表A列有重复的提取