如何可以吧相同内容剪切到另外一个表上

xyh2732

66.rar (43.33 KB, 下载次数: 13)

2013-5-22 13:59 上传

点击文件名下载附件 请教一下，可否以H列数据为主，查找A列上的数据把相同号码及J列（金额）相同的数据剪切到“相符”工作表上
比如第二行数据的H列是CCIN13040005 ,在A列找出对应的号码并且金额相同，把它剪切到“相符”工作表里面。

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, Arr1, Arr2, j&, aa
   
3. Dim d, k, t
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Sheet2.Activate
   
6. Arr = [a1].CurrentRegion
   
7. Arr1 = [a1].Resize(UBound(Arr), 7)
   
8. Arr2 = [h1].Resize(UBound(Arr), 3)
   
9. For i = 2 To UBound(Arr)
   
10.     d(Arr(i, 1)) = d(Arr(i, 1)) & i & ","
    
11. Next
    
12. For i = 2 To UBound(Arr)
    
13.     If d.exists(Arr(i, 8)) Then
    
14.         t = d(Arr(i, 8))
    
15.         t = Left(t, Len(t) - 1)
    
16.         If InStr(t, ",") Then
    
17.             aa = Split(t, ",")
    
18.             For j = 0 To UBound(aa)
    
19.                 If Arr(aa(j), 10) = Arr(i, 10) Then
    
20.                     With Sheet4
    
21.                         n = .[a65536].End(xlUp).Row + 1
    
22.                         .Cells(n, 1).Resize(1, 7) = Application.Index(Arr1, aa(j), 0)
    
23.                         .Cells(n, 8).Resize(1, 3) = Application.Index(Arr2, i, 0)
    
24.                     End With
    
25.                 End If
    
26.             Next
    
27.         Else
    
28.                 If Arr(t, 10) = Arr(i, 10) Then
    
29.                     With Sheet4
    
30.                         n = .[a65536].End(xlUp).Row + 1
    
31.                         .Cells(n, 1).Resize(1, 7) = Application.Index(Arr1, t, 0)
    
32.                         .Cells(n, 8).Resize(1, 3) = Application.Index(Arr2, i, 0)
    
33.                     End With
    
34.                 End If
    
35.         End If
    
36.     End If
    
37. Next
    
38. End Sub
    

复制代码

蓝桥玄霜

请见附件。点击按钮即可。

xyh2732

蓝桥玄霜 发表于 2013-5-22 17:18
请见附件。点击按钮即可。

感谢你的帮忙，相同数据应该有一一对应的两行才对，为什么只有一行？还有 整理 表上相同的数据应该剪切过相符表里，请帮忙在看看，谢谢！