求助数据添加，感谢帮助

任雨听风

添加一个功能按钮，将工作表（对照库添加）里的内容，自动添加到工作表（对照信息）里面，内容不覆盖原来内容，在原有内容下面添加，添加时列与列一一对应，添加完成后工作表（对照库添加）里的内容自动删除

ykcbf1100

请重新上传附件，目前附件下载后无法打开。

任雨听风

已重新上传

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.12.16
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("对照库添加")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         c = .UsedRange.Columns.Count
   
7.         arr = .[a1].Resize(r, c)
   
8.         .UsedRange.Offset(1).ClearContents
   
9.     End With
   
10.     With Sheets("对照信息")
    
11.         r = .Cells(Rows.Count, 1).End(3).Row
    
12.         c = .UsedRange.Columns.Count
    
13.         zrr = .[a1].Resize(r, c)
    
14.         For j = 1 To UBound(zrr, 2)
    
15.             s = zrr(1, j)
    
16.             d(s) = j
    
17.         Next
    
18.         ReDim brr(1 To 1000, 1 To c)
    
19.         For i = 2 To UBound(arr)
    
20.             If arr(i, 1) <> Empty Then
    
21.                 m = m + 1
    
22.                 For j = 1 To UBound(arr, 2)
    
23.                     If InStr(arr(1, j), "（") Then
    
24.                         l = InStr(arr(1, j), "（")
    
25.                         s = Left(arr(1, j), l - 1)
    
26.                     Else
    
27.                         s = arr(1, j)
    
28.                     End If
    
29.                     If d.exists(s) Then
    
30.                         brr(m, d(s)) = arr(i, j)
    
31.                     End If
    
32.                 Next
    
33.             End If
    
34.         Next
    
35.         .Cells(r + 1, 1).Resize(m, c) = brr
    
36.     End With
    
37.     Set d = Nothing
    
38.     Application.ScreenUpdating = False
    
39.     MsgBox "OK！"
    
40. End Sub
    

复制代码