比对两表名称提取重复另存

xing_chen

老师！有簿，需提取2表中重复名称另存表。敬请老师赐教！谢谢！

杨建营

请楼主参考。

李小超yys

1. Sub aaa()
   
2. 
   
3.     i = 2
   
4.     Z = 2
   
5.     Do While Sheet1.Cells(i, 1) <> ""
   
6.         k = 2
   
7.         Do While Sheet2.Cells(k, 1) <> ""
   
8.             If Sheet1.Cells(i, 1) = Sheet2.Cells(k, 1) Then
   
9.                 Sheets("另存").Cells(Z, 1) = Sheet1.Cells(i, 1)
   
10.                 Z = Z + 1
    
11.             End If
    
12.         k = k + 1
    
13.         Loop
    
14.         
    
15.     i = i + 1
    
16.     Loop
    
17. End Sub
    

复制代码

xing_chen

杨建营 发表于 2023-3-16 15:31
请楼主参考。

谢谢老师！运行如愿！
另若源表的表头是2行而不是现在的1行，则生成的结果（结果表的表头还是1行），那末句怎么修改?

xing_chen

李小超yys 发表于 2023-3-16 15:44

谢谢老师，运行如愿！
花在旅途，到时献上

ykcbf1100

这个用字典比较简单吧。

杨建营

这样的情况改我画红框的数字，从2改成3。

gwjkkkkk

Option Explicit
Sub TEST()
    Dim ar(1 To 2), i&, j&, r&, strFileName$
   
    Application.ScreenUpdating = False
    For i = 1 To UBound(ar)
        ar(i) = Sheets(i).[A1].CurrentRegion
        r = 1
    Next i
    For i = 2 To UBound(ar(1))
         For j = 2 To UBound(ar(2))
             If ar(2)(j, 1) = ar(1)(i, 1) Then
                 r = r + 1
                 ar(1)(r, 1) = ar(2)(j, 1)
             End If
         Next j
    Next i
   
    With Workbooks.Add
        strFileName = ThisWorkbook.Path & "\" & "另存"
        With .Sheets(1).[A1].Resize(r)
            .Value = ar(1)
        End With
        .SaveAs strFileName
        .Close
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

数组法请参考。。。

xing_chen

gwjkkkkk 发表于 2023-3-16 20:10
数组法请参考。。。

谢谢老师！运行如愿！