Hsieh

¦^´_ 1# jcchiang

1.     Sub ex()
   
2. Dim Rng As Range
   
3. With Sheet2
   
4.   r = 2
   
5.   Do Until .Cells(r, 1) = ""
   
6.   a = .Cells(r, 1)
   
7.   With Sheet1
   
8.      Set c = .Columns("A").Find(a, lookat:=xlWhole)
   
9.      If Not c Is Nothing Then
   
10.      Set c = c.MergeArea.Resize(, 6)
    
11.         If Rng Is Nothing Then
    
12.            Set Rng = c
    
13.         Else
    
14.            Set Rng = Union(Rng, c)
    
15.         End If
    
16.      End If
    
17.   End With
    
18.   r = r + 1
    
19.   Loop
    
20. End With
    
21. With Sheet3
    
22.   .UsedRange.Offset(1).Clear
    
23.   Rng.Copy .[A2]
    
24. End With
    
25. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 4# jcchiang

1. Sub ex()
   
2. 
   
3. Dim Rng As Range, a, b As Range, c As Range
   
4. 
   
5. With Sheet2
   
6.   r = 2
   
7.   Do Until .Cells(r, 1) = ""
   
8.   a = .Cells(r, 1)
   
9.   With Sheet1
   
10.   Set c = Nothing
    
11.     For Each b In .Range(.[A2], .[A65536].End(xlUp))
    
12.         If b = a Then
    
13.            If c Is Nothing Then
    
14.            Set c = b.MergeArea.Resize(, 6)
    
15.            Else
    
16.            Set c = Union(c, b.MergeArea.Resize(, 6))
    
17.            End If
    
18.         End If
    
19.     Next
    
20.      If Not c Is Nothing Then
    
21.         If Rng Is Nothing Then
    
22.            Set Rng = c
    
23.         Else
    
24.            Set Rng = Union(Rng, c)
    
25.         End If
    
26.      End If
    
27.   End With
    
28.   r = r + 1
    
29.   Loop
    
30. End With
    
31. With Sheet3
    
32.   .UsedRange.Offset(1).Clear
    
33.   Rng.Copy .[A2]
    
34. End With
    
35. End Sub

½Æ»s¥N½X