GBKEE

¦^´_ 1# amu1129

1. Sub Ex()
   
2.     Dim AR, d As Object, Rng As Range, E, i%, Sh$, DKey
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheet1
   
5.         AR = Split(.[B1], ",")
   
6.         For i = 0 To UBound(AR)
   
7.             For Each E In .Range("B4", .[B4].End(xlDown))
   
8.                 If .Cells(E.Row, "F") = AR(i) Then
   
9.                     d(E & E.Offset(, 1)) = Array(AR(i), E.Offset(, 1), E.Offset(, 5))
   
10.                     If InStr(Sh, E) = 0 Then Sh = IIf(Sh <> "", Sh & "," & E, E)
    
11.                 End If
    
12.             Next
    
13.         Next
    
14.     End With
    
15.     i = 2
    
16.     For Each E In Split(Sh, ",")
    
17.         On Error GoTo Er
    
18.         With Sheets(i)
    
19.             .Cells.Clear
    
20.             .[B2] = E
    
21.             .[B4].Resize(, 3) = Array("¤Ø¤o", "½s¸¹", "¼Æ¶q")
    
22.             For Each DKey In d.keys
    
23.                 If DKey Like E & "*" Then
    
24.                     With .Range("b" & Rows.Count).End(xlUp).Offset(1)
    
25.                         .Resize(, 3) = d(DKey)
    
26.                         .Offset(, -1) = .Row - 4
    
27.                     End With
    
28.                 End If
    
29.             Next
    
30.             With .Range("b" & Rows.Count).End(xlUp)
    
31.                 .Offset(1) = "¦X­p"
    
32.                 .Offset(1, 2) = Evaluate("=SUM(" & .Offset(, 2).Address(, , , 1) & ":D5)")
    
33.             End With
    
34.             .Range("B4").CurrentRegion.Borders.LineStyle = 1
    
35.         End With
    
36.         i = i + 1
    
37.     Next
    
38. Exit Sub
    
39. Er:
    
40.     If Err = 9 Then
    
41.         Sheets.Add , Sheets(Sheets.Count)
    
42.         Resume
    
43.     Else
    
44.         MsgBox Err
    
45.     End If
    
46. End Sub

½Æ»s¥N½X