½Ð°Ý¦p¦ó³s±µ¥t¤@­ÓÀÉ®×Â^¨ú¸ê®Æ©M±Æ§Ç

amu1129

§Ú¦³¤@¨Ç¸ê®Æ¦p¤U¹ÏA

¤U¸ü (65.23 KB)

2010-8-25 00:02

§Ú·Q¦p¤U¹ÏB&Cªºªí®æB2¿é¤J°Ó«~¦WºÙ
µM«á·|¦Û°Ê³sµ²¨ì¹ÏAªºÀÉ®×
Â^¨ú¤Ø¤o¡B½s¸¹©M¼Æ¶qªº¸ê®Æ
¦Ó¥B«e­±¦³½s¸¹
¤Ø¤o¥HB01¡÷B02¡÷A01¡÷A02±Æ§Ç
½s¸¹«h»¼¼W±Æ§Ç

³Ì¤U­±«h¬O¦³¼Æ¶qªº¦X­p
±µµÛ¥Hªí®æ®Ø°_¨Ó
½Ð°Ý³o¸Ó«ç»ò¼g

¤U¸ü (21.03 KB)

2010-8-25 00:03

  

¤U¸ü (25.13 KB)

2010-8-25 00:03

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

amu1129

¤£¦n·N«ä~ª©¥D
¨S¦³¤ÏÀ³­C
¬OÁٻݭn§ó§ï¤°»ò¶Ü

Hsieh

¦^´_ 3# amu1129
¦bBOOK1¸òBOOK2ªºSheet1¼Ò²Õ¤º¿é¤Jµ{¦¡½X
§ïÅÜBOOK1¸òBOOK2ªºSheet1ªºb2Àx¦s®æ¸Õ¸Õ

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Dim Ar(), Ay(), A As Range
   
3. Ky = Array("B01", "B02", "A01", "A02")
   
4. If Target.Address <> "$B$2" Then Exit Sub
   
5. fs = ThisWorkbook.Path & "\5 B01,B02,A01,A02.xls"
   
6. ReDim Preserve Ay(k)
   
7. Ay(k) = Array("", "¤Ø¤o", "½s¸¹", "¼Æ¶q")
   
8. k = k + 1
   
9. With Workbooks.Open(fs)
   
10.    With .Sheets(1)
    
11.      For Each A In .Range(.[B4], .[B65536].End(xlUp))
    
12.         If A = Target Then
    
13.            ReDim Preserve Ar(s)
    
14.            Ar(s) = Array(A.Offset(, 4).Value, A.Offset(, 1).Value, A.Offset(, 5).Value)
    
15.            cnt = cnt + A.Offset(, 5).Value
    
16.            s = s + 1
    
17.         End If
    
18.     Next
    
19.    End With
    
20.    .Close 0
    
21. End With
    
22. For i = 0 To 3
    
23.    For j = 0 To UBound(Ar)
    
24.       If Ar(j)(0) = Ky(i) Then
    
25.          ReDim Preserve Ay(k)
    
26.          Ay(k) = Array(k, Ar(j)(0), Ar(j)(1), Ar(j)(2))
    
27.          k = k + 1
    
28.       End If
    
29.    Next
    
30. Next
    
31. ReDim Preserve Ay(k)
    
32. Ay(k) = Array("", "¦X­p", "", cnt)
    
33. k = k + 1
    
34. With Me
    
35.    .[A3:D65536].Clear
    
36.    .[A4].Resize(k, 4).Value = Application.Transpose(Application.Transpose(Ay))
    
37.    .Range("A2").Resize(k + 2, 4).Borders.LineStyle = 1
    
38.    .Range("A2").Resize(k + 2, 4).Borders.Weight = xlThin
    
39.    .Range("B2").Resize(k + 2, 3).BorderAround 1, xlThick, xlColorIndexAutomatic
    
40. End With
    
41. End Sub

½Æ»s¥N½X

amu1129

¤£¦n·N«ä~¤£ª¾¹D¬°¤°»ò´N¬O¤£·|¶]
¦pªG§Ú·Q§ï¦¨¦p¤U¹Ï

¤U¸ü (105.63 KB)

2010-9-2 22:03

µ{¦¡¤@
¤@¶}©l¬°½s¸¹1¹Ï
±µµÛ¦bÀx¦s®æB2¿é¤J
·|¶]¥X¦p½s¸¹2¹Ï

µ{¦¡¤G
¦bFÄæ­«½Æ½s¸¹¤U¶K¤W­«½Æ½s¸¹(½s¸¹3¹Ï)
·|¦Û°Ê±N­«½Æªº½s¸¹µ¹§R°£
±µµÛ¤~¶]¥X¤U­±¼Æ¶qªº¦X­p
³Ì«á¥H®Ø½u°_¨Ó

³Â·Ð½ÐÀ°§Ú­×§ï¤@¤U~ÁÂÁÂ

Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð

°õ¦æ«e:

¤U¸ü (164.58 KB)

2023-6-19 14:18

°õ¦æµ²ªG:

¤U¸ü (211.84 KB)

2023-6-19 14:19

Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 1000, 1 To 250), Z, B, v&, i&, R&, C%, x%, u&, T5$, T1$
[I:IV].Delete
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range([Sheet1!G4], [Sheet1!B65536].End(xlUp))
For Each B In Split([B1], ",")
   i = i + 1: Z("/" & B & "/") = i
Next
For i = 1 To UBound(Brr)
   T1 = Brr(i, 1): T5 = Brr(i, 5)
   If Z("/" & T5 & "/") = "" Then GoTo i01
   B = Z(T1)
   R = Z(T1 & "/r") + 1
   If Not IsArray(B) Then
      B = Crr
      x = x + 1
      Z(T1 & "/c") = x
      Z(T1 & "/r") = 1
   End If
   B(R, 1) = Z("/" & T5 & "/")
   B(R, 2) = T5
   B(R, 3) = Brr(i, 2)
   B(R, 4) = Val(Brr(i, 6))
   Z(T1 & "/r") = R
   Z(T1) = B
i01: Next
For Each B In Z.KEYS
   If Not IsArray(Z(B)) Then GoTo v01
   u = Z(B & "/c")
   v = Z(B & "/r")
   With Cells(1, (u - 1) * 5 + 9).Resize(v + 2, 4)
      .Item(1) = "§Ç¸¹ \ " & B
      .Item(2) = "¤Ø¤o"
      .Item(3) = "½s¸¹"
      .Item(4) = "¼Æ¶q"
      .Item(2, 1).Resize(v, 4).Value = Z(B)
      .Sort KEY1:=.Item(1), Order1:=1, _
            Key2:=.Item(3), Order2:=1, Header:=1
      With .Item(2, 1).Resize(v)
         .Value = "=ROW(" & .Address(0, 0) & ")-1"
      End With
      .Item(v + 2, 2) = "¦X­p"
      .Item(v + 2, 4) = "=SUM(" & .Item(2, 4).Resize(v).Address & ")"
      .EntireColumn.AutoFit
      .Borders.LineStyle = 1
   End With
v01: Next
Set Z = Nothing: Erase Brr, Crr
End Sub