Hsieh

¦^´_ 4# Baracuda
³o¼Ë¥Î¦X¨Ö¦C¦L¦n¹³¤£¬O«Ü¦X¾A
ª½±µ¥ÎEXCEL¿é¥X¥X³f³æ¤ñ¸û²³æ

1. Sub ex()
   
2. Dim Ar(), A As Range, C As Range
   
3. With Sheet2
   
4. For Each A In .Range(.[A2], .[A65536].End(xlUp))
   
5.    With Sheet1
   
6.    For Each C In .Range(.[A2], .[A65536].End(xlUp))
   
7.       If C = A Then
   
8.       ReDim Preserve Ar(s)
   
9.       Ar(s) = Array(A.Offset(, 1).Value, A, C.Offset(, 1).Value, C.Offset(, 2).Value, C.Offset(, 3).Value, C.Offset(, 4).Value, C.Offset(, 5).Value)
   
10.       s = s + 1
    
11.       End If
    
12.    Next
    
13.    End With
    
14.    With Sheet5
    
15.    i = 0: .[F3] = A: .[B5:F9] = ""
    
16.    Do Until i > UBound(Ar)
    
17.       r = i Mod 5
    
18.       .Cells(r + 5, 2).Resize(, 5) = Array(Ar(i)(2), Ar(i)(3), Ar(i)(4), Ar(i)(5), Ar(i)(6))
    
19.       If r = 4 Or i = UBound(Ar) Then
    
20.       .[F10] = r + 1 & "µ§¦@" & s & "µ§"
    
21.          .PrintPreview
    
22.          .[B5:F9] = ""
    
23.       End If
    
24.       i = i + 1
    
25.    Loop
    
26.    End With
    
27.    With Sheet3 '¼g¤J¿é¥X¤º®e¤u§@ªí¡A­Y¤£±Ä¥Î¦X¨Ö¦C¦L¥i§R°£¦¹°Ï¬q
    
28.    .[A65536].End(xlUp).Offset(1).Resize(s, 7) = Application.Transpose(Application.Transpose(Ar))
    
29.    End With
    
30.    s = 0: Erase Ar
    
31. Next
    
32. End With
    
33. End Sub

½Æ»s¥N½X

¥X³f³æ.rar (15.68 KB)

¤U¸ü¦¸¼Æ: 57

2011-5-3 23:57