[已解决]改代码

要用就学

Sub chaxun()
Dim i%, j%, y%
ends = Columns(1).Find("*", searchdirection:=xlPrevious).Row
Sheets("sheet2").Range("b2:f100").Clear
For Each Rng In Range("a2:a" & ends)
   m = m + 1
If Rng Like Sheets("sheet2").Range("a2") Then
   k = k + 1
   Range("a" & m + 1).Copy Sheets("sheet2").Range("b" & k + 1)
   Range("b" & m + 1).Copy Sheets("sheet2").Range("c" & k + 1)
   Range("c" & m + 1).Copy Sheets("sheet2").Range("d" & k + 1)
  End If
  Next
  i = Sheet2.Range("b1").CurrentRegion.Rows.Count - 1
  j = Sheet2.Range("b1").CurrentRegion.Columns.Count
  y = Application.CountA(Sheet3.Columns(1))
  Sheet2.Range("b2").Resize(i, j).Copy Sheet3.Range("a1").Offset(y)
End Sub1、想把红色a2改成变量，使按照sheet2的A列依次查找并保存
2、蓝色部分是将每次找到的结果保存在sheet3表中，如果保存过就不保存怎么改进

最佳答案

月排行榜 / 总排行榜

dsmch

2014-5-10 19:43

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i&, s&, j%, k%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a1").CurrentRegion
   
5. brr = Range("a2").CurrentRegion
   
6. ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
   
7. For i = 2 To UBound(arr)
   
8.     d(arr(i, 1)) = d(arr(i, 1)) & "," & i
   
9. Next
   
10. For i = 1 To UBound(brr)
    
11.     If d.exists(brr(i, 1)) Then
    
12.         x = Split(d(brr(i, 1)), ",")
    
13.         For j = 1 To UBound(x)
    
14.             s = s + 1
    
15.             For k = 1 To UBound(arr, 2)
    
16.                 crr(s, k) = arr(x(j), k)
    
17.             Next
    
18.         Next
    
19.     End If
    
20. Next
    
21. Sheet3.Range("a1").Resize(s, UBound(crr, 2)) = crr
    
22. End Sub
    

复制代码

跳转到最佳答案楼层

要用就学

依照sheet2的A列学员名单，在sheet1表中找出同名同姓的人，并在其好几十条其信息中有选择选取2至3种复制到sheet3表中，

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i&, s&, j%, k%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a1").CurrentRegion
   
5. brr = Range("a2").CurrentRegion
   
6. ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
   
7. For i = 2 To UBound(arr)
   
8.     d(arr(i, 1)) = d(arr(i, 1)) & "," & i
   
9. Next
   
10. For i = 1 To UBound(brr)
    
11.     If d.exists(brr(i, 1)) Then
    
12.         x = Split(d(brr(i, 1)), ",")
    
13.         For j = 1 To UBound(x)
    
14.             s = s + 1
    
15.             For k = 1 To UBound(arr, 2)
    
16.                 crr(s, k) = arr(x(j), k)
    
17.             Next
    
18.         Next
    
19.     End If
    
20. Next
    
21. Sheet3.Range("a1").Resize(s, UBound(crr, 2)) = crr
    
22. End Sub
    

复制代码

要用就学

dsmch 发表于 2014-5-10 19:43

高手！您写的代码效率的确高，运行以后效果极佳！我看不懂，解释一下代码可好？

dsmch

Sub Macro1()
Dim arr, brr, crr, d, i&, s&, j%, k%
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a1").CurrentRegion '表1
brr = Range("a2").CurrentRegion '表2
ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 2 To UBound(arr) '循环数组
    d(arr(i, 1)) = d(arr(i, 1)) & "," & i '第一列相同的所在的行
Next
For i = 1 To UBound(brr)
    '如果在表1存在，找出该值对应的行
    If d.exists(brr(i, 1)) Then
        '分列成对应的行
        x = Split(d(brr(i, 1)), ",")
        For j = 1 To UBound(x)
            s = s + 1
            '数组arr对应的行赋值数组crr
            For k = 1 To UBound(arr, 2)
                crr(s, k) = arr(x(j), k)
            Next
        Next
    End If
Next
'数组crr赋值表3
Sheet3.Range("a1").Resize(s, UBound(crr, 2)) = crr
End Sub