[字典] 配对与覆制

On_fire

[字典]配对与覆制

1.

A页是资料页

2.

B列(主)跟J列(副),循环做配对流程如下,

B1 配对J1, J2.....

B2 配对  J1, J2......

当两格内容数据是一样的, 就將 [ J列的那一行資料 ], 複制到B页

3.

C列(主)跟K列(副),循环做配对流程如下,

C1 配对 K1, K2.....

C2 配对  K1, K2......

当两格内容数据是一样的, 就將 [ K列的那一行資料 ], 複制到C页

数据N多, 请求大神们, 老师帮忙! 谢谢!

feiren228

没看懂什么意思。。。。。

liulang0808

Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Dim rnb As Range, rnc As Range
    Sheets("a").Select
    For j = 1 To Cells(Rows.Count, 2).End(3).Row
        If Len(Cells(j, 2)) > 0 Then
            For i = 1 To Cells(Rows.Count, "j").End(3).Row
                If Cells(j, 2) = Cells(i, "j") Then
                    If rnb Is Nothing Then
                        Set rnb = Cells(i, 1)
                    Else
                        Set rnb = Union(rnb, Cells(i, 1))
                    End If
                End If
            Next i
        End If
    Next j
    If Not rnb Is Nothing Then rnb.EntireRow.Copy Sheets("b").Cells(1, 1)
    For j = 1 To Cells(Rows.Count, 3).End(3).Row
        If Len(Cells(j, 3)) > 0 Then
            For i = 1 To Cells(Rows.Count, "k").End(3).Row
                If Cells(j, 3) = Cells(i, "k") Then
                    If rnc Is Nothing Then
                        Set rnc = Cells(i, 1)
                    Else
                        Set rnc = Union(rnc, Cells(i, 1))
                    End If
                End If
            Next i
        End If
    Next j
    If Not rnc Is Nothing Then rnc.EntireRow.Copy Sheets("c").Cells(1, 1)
    Application.ScreenUpdating = True
End Sub

liulang0808

见附件内容，看看是否满足需求吧

On_fire

feiren228 发表于 2015-5-19 20:15
没看懂什么意思。。。。。

1.
A页是资料页

2.
B列格内数据 跟 J列的格内数据, 循环做配对流程如下,
当B1格的内容  =  J1格的内容,  两格内容是一样的, 就将 [ J1那一行资料 ], 复制到B页
当B1格的内容  =  J2格的内容, 两格内容是一样的, 就将 [ J2那一行资料 ], 复制到B页……
.....
当B2格的内容  =  J1格的内容,  两格内容是一样的, 就将 [ J1那一行资料 ], 复制到B页
当B2格的内容  =  J2格的内容, 两格内容是一样的, 就将 [ J2那一行资料 ], 复制到B页……
.....

3.
C列格内数据 跟 K列的格内数据, 循环做配对流程如下,
当C1格的内容  =  K1格的内容,  两格内容是一样的, 就将 [ K1那一行资料 ], 复制到C页
当C1格的内容  =  K2格的内容, 两格内容是一样的, 就将 [ K2那一行资料 ], 复制到C页……
.....
当C2格的内容  =  K1格的内容,  两格内容是一样的, 就将 [ K1那一行资料 ], 复制到C页
当C2格的内容  =  K2格的内容, 两格内容是一样的, 就将 [ K2那一行资料 ], 复制到C页……
.....

On_fire

liulang0808 发表于 2015-5-19 20:23
见附件内容，看看是否满足需求吧

非常谢谢老师的热心帮忙, 可惜当数据多的时候, 效果有点不一样!

请问能改用[字典], 不用数组吗?

chenbiao2012

1. Sub test()
   
2.     With Sheets("A")
   
3.         arr = .Range("b1:k" & .UsedRange.Rows.Count)
   
4.     End With
   
5.     a = Array("B", "C")
   
6.     For c = 1 To 2
   
7.         ReDim brr(1 To 1000, 1 To 10)
   
8.         n = 0
   
9.         For i = 1 To UBound(arr)
   
10.             If Len(arr(i, c)) > 0 Then
    
11.                 For j = 1 To UBound(arr)
    
12.                     If arr(i, c) = arr(j, 8 + c) Then
    
13.                         n = n + 1
    
14.                         For m = 1 To 10
    
15.                             brr(n, m) = arr(j, m)
    
16.                         Next
    
17.                     End If
    
18.                 Next
    
19.             End If
    
20.         Next
    
21.         With Sheets(a(c - 1))
    
22.             .UsedRange.ClearContents
    
23.             .[b1].Resize(n, 10) = brr
    
24.         End With
    
25.     Next
    
26. End Sub
    
27. 
    

复制代码

On_fire

chenbiao2012 发表于 2015-5-19 22:08

非常谢谢老师帮忙, 数据多了也不行, 有错误提示!

chenbiao2012

可以上传附件，并标示出错地方吗

On_fire

chenbiao2012 发表于 2015-5-19 22:47
可以上传附件，并标示出错地方吗

谢谢老师