Hsieh

¦^´_ 1# luke

1. Sub ex()
   
2. Dim Rng As Range, A As Range
   
3. k = 1
   
4. For Each sh In Sheets(Array("sheet1", "sheet2"))
   
5.    With sh
   
6.    For i = 1 To 2
   
7.    Set Rng = Nothing
   
8.     For Each A In .Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp))
   
9.         If A.Interior.ColorIndex = i * 3 Then
   
10.            If Rng Is Nothing Then Set Rng = A.Offset(, 1).Resize(, 3) Else Set Rng = Union(Rng, A.Offset(, 1).Resize(, 3))
    
11.         End If
    
12.      Next
    
13.      r = Application.CountA(sheet3.Columns(k)) + 1
    
14.    If Not Rng Is Nothing Then Rng.Copy sheet3.Cells(r, k)
    
15.    Next
    
16.    End With
    
17.    k = k + 3
    
18. Next
    
19. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 3# luke

1. Sub ex()
   
2. Dim Rng As Range, A As Range, Ar()
   
3. k = 1
   
4. For Each sh In Sheets(Array("sheet1", "sheet2"))
   
5.    With sh
   
6.    For i = 1 To 2
   
7.    Set Rng = Nothing
   
8.     For Each A In .Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp))
   
9.         If A.Interior.ColorIndex = i * 3 Then
   
10.            ReDim Preserve Ar(s)
    
11.            Ar(s) = Array(A, A.Offset(, 1), "", "", A.Offset(, 2))
    
12.            s = s + 1
    
13.         End If
    
14.      Next
    
15.      r = Application.CountA(sheet3.Columns(k)) + 1
    
16.    If s > 0 Then
    
17.       With sheet3.Cells(r, k).Resize(s, 5)
    
18.          .Value = Application.Transpose(Application.Transpose(Ar)): Erase Ar: s = 0
    
19.          .Interior.ColorIndex = i * 3
    
20.       End With
    
21.    End If
    
22.    Next
    
23.    End With
    
24.    k = k + 5
    
25. Next
    
26. End Sub

½Æ»s¥N½X