198188

¦^´_  198188


    ½Ð«e½ú¦Û¦æ¸Õ¸Õ¼g¤@¬q¥N½X¥ý§âData ¦P¸¹¬Û¥[¡A¦A±NRead¤ñ¹ï2¦¸Data
Andy2483 µoªí©ó 2025-11-6 19:04

1. Brr = [Read!A1].CurrentRegion
   
2. For i = 2 To UBound(Brr): Z(Brr(i, 1)) = Val(Brr(i, 3)): Next
   
3. N = 1
   
4. For i = 2 To UBound(Brr)
   
5.    If Z.Exists(Brr(i, 1)) Then
   
6.           Z(Brr(N, 3)) = Z(Brr(N, 3)) + Brr(i, 3)
   
7.       End If
   
8. Next

½Æ»s¥N½X

§Ú¹Á¸Õ±N¦Ç¦âªº¼Æ¶q°O¤J¦r¨å¡AÀY¥|­Ó¦¨¥\°O¤J¡A¦ý¬O«á­±¤£À´±o¥[Á`¡A

198188

¦^´_  198188


    ½Ð«e½ú¦Û¦æ¸Õ¸Õ¼g¤@¬q¥N½X¥ý§âData ¦P¸¹¬Û¥[¡A¦A±NRead¤ñ¹ï2¦¸Data
Andy2483 µoªí©ó 2025-11-6 19:04

  «e½ú¡A²Ä¤@¨B ±NRead ªíªº CODE ©ñ¤J¦r¨å¡AQty ¤]©ñ¤J¦r¨å¨Ã¬Û¦P Code ¥[Á`¡A³o³¡¤À§Ú¸Õ¤F«Ü¦h¦¸¡A³£¤£¦¨¥\¡C
½Ð«üÂI¤@¤U«á¾Ç¡C

198188

1. Sub sumdata()
   
2. Dim i As Long
   
3. Dim n As Long
   
4. Dim ar, arr, brr As Variant
   
5. Dim dict As New Dictionary
   
6. 
   
7. ar = [A1].CurrentRegion
   
8. Set dict = CreateObject("Scripting.Dictionary")
   
9. 
   
10. With dict
    
11. For i = 1 To UBound(ar, 1)
    
12. .Item(ar(i, 1)) = .Item(ar(i, 1)) + ar(i, 3)
    
13. Next i
    
14. arr = Array(.Keys, .Items)
    
15. n = .Count
    
16. End With
    
17. 
    
18. [O1].Resize(n, 2).Value = Application.Transpose(arr)
    
19. 
    
20. 
    
21. brr = Sheets("Data").UsedRange
    
22. For i = 2 To UBound(brr)
    
23.    If dict(brr(i, 8)) > 0 Then
    
24.       m = m + 1
    
25.       For j = 1 To 13: brr(m, j) = brr(i, j): Next
    
26.       brr(m, 3) = brr(m, 3) * dict(brr(i, 8))
    
27.          
    
28.    End If
    
29. Next
    
30. If m > 0 Then Sheets("Read").[A13].Resize(m, 13) = brr: m = 0 Else MsgBox "Frame per Dwg_Nothing"
    
31. 
    
32. End Sub

½Æ»s¥N½X

¦^´_  198188


    ½Ð«e½ú¦Û¦æ¸Õ¸Õ¼g¤@¬q¥N½X¥ý§âData ¦P¸¹¬Û¥[¡A¦A±NRead¤ñ¹ï2¦¸Data
Andy2483 µoªí©ó 2025-11-6 19:04

«e½ú¡A§Ú§¹¦¨²Ä¤@½ü¤F¡C

198188

¦^´_  198188


    ½Ð«e½ú¦Û¦æ¸Õ¸Õ¼g¤@¬q¥N½X¥ý§âData ¦P¸¹¬Û¥[¡A¦A±NRead¤ñ¹ï2¦¸Data
Andy2483 µoªí©ó 2025-11-6 19:04

1. Sub sumdata()
   
2. Dim i As Long
   
3. Dim n As Long
   
4. Dim ar, arr, brr As Variant
   
5. Dim dict As New Dictionary
   
6. .Column("O:P").Delete
   
7. ar = [A1].CurrentRegion
   
8. lastRow = UBound(ar)
   
9. Set dict = CreateObject("Scripting.Dictionary")
   
10. 
    
11. With dict
    
12. For i = 1 To UBound(ar, 1)
    
13. .Item(ar(i, 1)) = .Item(ar(i, 1)) + ar(i, 3)
    
14. Next i
    
15. arr = Array(.Keys, .Items)
    
16. n = .Count
    
17. End With
    
18. [O1].Resize(n, 2).Value = Application.Transpose(arr)
    
19. 
    
20. brr = Sheets("Data").UsedRange
    
21. For i = 2 To UBound(brr)
    
22.    If dict(brr(i, 8)) > 0 Then
    
23.       m = m + 1
    
24.       For j = 1 To 13: brr(m, j) = brr(i, j): Next
    
25.       brr(m, 3) = brr(m, 3) * dict(brr(i, 8))
    
26.    
    
27.    End If
    
28. Next
    
29. If m > 0 Then Sheets("Read").Range("A" & lastRow + 1).Resize(m, 13) = brr: m = 0
    
30. 
    
31. ar = Range("A" & lastRow + 1).CurrentRegion
    
32. lastRow1 = UBound(ar)
    
33. ar = Range("A" & lastRow & ":M" & lastRow1)
    
34. Set dict = CreateObject("Scripting.Dictionary")
    
35. 
    
36. With dict
    
37. For i = 2 To UBound(ar, 1)
    
38. .Item(ar(i, 1)) = .Item(ar(i, 1)) + ar(i, 3)
    
39. Next i
    
40. arr = Array(.Keys, .Items)
    
41. n = .Count
    
42. End With
    
43. [O1].Resize(n, 2).Value = Application.Transpose(arr)
    
44. 
    
45. brr = Sheets("Data").UsedRange
    
46. For i = 1 To UBound(brr)
    
47.    If dict(brr(i, 8)) > 0 Then
    
48.       m = m + 1
    
49.       For j = 1 To 13: brr(m, j) = brr(i, j): Next
    
50.       brr(m, 3) = brr(m, 3) * dict(brr(i, 8))
    
51.    
    
52.    End If
    
53. Next
    
54. If m > 0 Then Sheets("Read").Range("A" & lastRow1 + 1).Resize(m, 13) = brr: m = 0
    
55. 
    
56. End Sub

½Æ»s¥N½X

«e½ú¡A¤w¸g§¹¦¨¡A½Ð«üÂI¡C

Andy2483

¦^´_ 9# 198188


    ³o¦nÃø,¤£ª¾¹D¹ï¤£¹ï,½Ð«e½ú«ü±Ð

°õ¦æµ²ªG:

¤U¸ü (73.55 KB)

4 ¤Ñ«e 16:37

Option Explicit
Sub TEST1()
Dim brr, X, Y, Z, K, Q, i&, j%, n&, T1$, T8$
Set Z = CreateObject("Scripting.Dictionary")
Set Y = CreateObject("Scripting.Dictionary")
Set X = CreateObject("Scripting.Dictionary")
brr = Sheets(1).[A1].CurrentRegion
For i = 2 To UBound(brr)
   If Y(brr(i, 1)) = "" Then
      Y(brr(i, 1)) = "(" & Val(brr(i, 3))
      Else
      Y(brr(i, 1)) = Y(brr(i, 1)) & "+" & Val(brr(i, 3))
   End If
Next
brr = Sheets(2).[A1].CurrentRegion
For i = 2 To UBound(brr)
   T1 = brr(i, 1)
   T8 = brr(i, 8)
   If Y.Exists(T8) Then
      If Not IsObject(Z(T8 & "/")) Then
         Set Z(T8 & "/") = CreateObject("Scripting.Dictionary")
         brr(i, 3) = Y(T8) & ")*(" & Val(brr(i, 3))
         Z(T1) = brr(i, 3)
         Else
         Z(T1) = Z(T8) & "+" & Val(brr(i, 3))
         brr(i, 3) = Y(T8) & ")*(" & Val(brr(i, 3))
      End If
      Z(T8 & "/")(i) = ""
      Z(T8) = brr(i, 3)
   End If
Next
For i = 2 To UBound(brr)
   T1 = brr(i, 1)
   T8 = brr(i, 8)
   If Z.Exists(T8) And Not Y.Exists(T8) Then
      If Not IsObject(Z(T8 & "/")) Then
         Set Z(T8 & "/") = CreateObject("Scripting.Dictionary")
         brr(i, 3) = Z(T8) & ")*(" & Val(brr(i, 3))
         X(T1) = brr(i, 3)
         Else
         X(T1) = X(T8) & "+" & Val(brr(i, 3))
         brr(i, 3) = Z(T8) & ")*(" & Val(brr(i, 3))
      End If
      Z(T8 & "/")(i) = ""
      X(T8) = brr(i, 3)
   End If
Next
For Each K In Z.Keys
   If IsObject(Z(K)) Then
      For Each Q In Z(K).Keys
         n = n + 1
         For j = 1 To UBound(brr, 2): brr(n, j) = brr(Q, j): Next
         brr(n, 3) = brr(n, 3) & ")": 'Brr(N, 3) = "=" & Brr(N, 3)
      Next
   End If
Next
If n > 0 Then Workbooks.Add: [A1].Resize(n, UBound(brr, 2)) = brr
End Sub

Andy2483

¦^´_ 14# 198188


    ÁÂÁ«e½ú«ü¾É,«Ü¦h¨S¬Ý¹Lªº,«á¾Ç°õ¦æ¥X²{°»¿ù,½Ð«e½ú«üÂI

¤U¸ü (98.97 KB)

4 ¤Ñ«e 16:40

198188

¦^´_  198188


    ÁÂÁ«e½ú«ü¾É,«Ü¦h¨S¬Ý¹Lªº,«á¾Ç°õ¦æ¥X²{°»¿ù,½Ð«e½ú«üÂI
Andy2483 µoªí©ó 2025-11-7 16:40

   

¤U¸ü (51.12 KB)

4 ¤Ñ«e 17:39

«e½ú¡A»Ý­n¥h ¤u¨ã =>³]©w¤Þ¥Î¶µ¥Ø => Microsoft Scripting Runtime
ªþ¤W½d¨Ò

Andy2483

¦^´_ 15# Andy2483


    ¤µ¤Ñ¾Ç²ß¥i¦h½ü­pºâ¤è®×,½Ð¦U¦ì«e½ú«ü±Ð

Option Explicit
Sub TEST2()
Const Ref = 2
Dim Brr, Crr, Y, Z(0 To Ref + 1), K, i&, j%, N&, T1$, T8$, d%
Set Y = CreateObject("Scripting.Dictionary")
For i = 0 To Ref + 1: Set Z(i) = CreateObject("Scripting.Dictionary"): Next
Brr = Sheets(1).[A1].CurrentRegion
For i = 2 To UBound(Brr)
   If Z(1)(Brr(i, 1)) = "" Then
      Z(1)(Brr(i, 1)) = "(" & Val(Brr(i, 3))
      Else
      Z(1)(Brr(i, 1)) = Z(1)(Brr(i, 1)) & "+" & Val(Brr(i, 3))
   End If
Next
Brr = Sheets(2).[A1].CurrentRegion
For d = 2 To Ref + 1
   For i = 2 To UBound(Brr)
      T1 = Brr(i, 1)
      T8 = Brr(i, 8)
      If Y.Exists(i) Then GoTo i01
      If Z(d - 1).Exists(T8) And Z(d - 1)(T8 & "/") = "" And Not Z(d - 2).Exists(T8) Then
         Brr(i, 3) = Z(d - 1)(T8) & ")*(" & Val(Brr(i, 3))
         Z(d)(T1) = Brr(i, 3)
         Z(d - 1)(T8 & "/") = Brr(i, 3)
         Y(i) = ""
         Z(d)(T8) = Brr(i, 3)
         ElseIf Z(d - 1)(T8 & "/") <> "" Then
            Z(d)(T1) = Z(d)(T8) & "+" & Val(Brr(i, 3))
            Brr(i, 3) = Z(d - 1)(T8) & ")*(" & Val(Brr(i, 3))
            Y(i) = ""
            Z(d)(T8) = Brr(i, 3)
      End If
i01: Next
Next
ReDim Crr(1 To Y.Count, 1 To UBound(Brr, 2))
For Each K In Y.Keys
   N = N + 1
   For j = 1 To UBound(Brr, 2): Crr(N, j) = Brr(K, j): Next
   Crr(N, 3) = Crr(N, 3) & ")": Crr(N, 5) = "=" & Crr(N, 3)
Next
If N > 0 Then Workbooks.Add: [A1].Resize(N, UBound(Brr, 2)) = Crr
End Sub

198188

¦^´_  Andy2483


    ¤µ¤Ñ¾Ç²ß¥i¦h½ü­pºâ¤è®×,½Ð¦U¦ì«e½ú«ü±Ð

Option Explicit
Sub TEST2()
Cons ...
Andy2483 µoªí©ó 2025-11-10 16:45

1. Option Explicit
   
2. Sub TEST2()
   
3. Const Ref = 2
   
4. Dim Brr, Crr, Y, Z(0 To Ref + 1), K, i&, j%, N&, T1$, T8$, d%
   
5. Set Y = CreateObject("Scripting.Dictionary")
   
6. For i = 0 To Ref + 1: Set Z(i) = CreateObject("Scripting.Dictionary"): Next
   
7. Brr = Sheets(1).[A1].CurrentRegion
   
8. For i = 2 To UBound(Brr)
   
9.    If Z(1)(Brr(i, 1)) = "" Then
   
10.       Z(1)(Brr(i, 1)) = Val(Brr(i, 3))
    
11.       Else
    
12.       Z(1)(Brr(i, 1)) = Z(1)(Brr(i, 1)) + Val(Brr(i, 3))
    
13.    End If
    
14. Next
    
15. Brr = Sheets(2).[A1].CurrentRegion
    
16. For d = 2 To Ref + 1
    
17.    For i = 2 To UBound(Brr)
    
18.       T1 = Brr(i, 1)
    
19.       T8 = Brr(i, 8)
    
20.       If Y.Exists(i) Then GoTo i01
    
21.       If Z(d - 1).Exists(T8) And Z(d - 1)(T8 & "/") = "" And Not Z(d - 2).Exists(T8) Then
    
22.          Brr(i, 3) = Z(d - 1)(T8) * Val(Brr(i, 3))
    
23.          Z(d)(T1) = Brr(i, 3)
    
24.          Z(d - 1)(T8 & "/") = Brr(i, 3)
    
25.          Y(i) = ""
    
26.          Z(d)(T8) = Brr(i, 3)
    
27.          ElseIf Z(d - 1)(T8 & "/") <> "" Then
    
28.             Z(d)(T1) = Z(d)(T8) + Val(Brr(i, 3))
    
29.             Brr(i, 3) = Z(d - 1)(T8) * Val(Brr(i, 3))
    
30.             Y(i) = ""
    
31.             Z(d)(T8) = Brr(i, 3)
    
32.       End If
    
33. i01: Next
    
34. Next
    
35. ReDim Crr(1 To Y.Count, 1 To UBound(Brr, 2))
    
36. For Each K In Y.Keys
    
37.    N = N + 1
    
38.    For j = 1 To UBound(Brr, 2): Crr(N, j) = Brr(K, j): Next
    
39.    Crr(N, 3) = Crr(N, 3): Crr(N, 5) = Crr(N, 3)
    
40. Next
    
41. If N > 0 Then Workbooks.Add: [A1].Resize(N, UBound(Brr, 2)) = Crr
    
42. End Sub

½Æ»s¥N½X

ÁÂÁ«e½ú«üÂI¡A½Ð°Ý¦pªGª½±µ­pºâQty, §Ú§R°£¤F¤@¨Ç¡§¡]¡^+ * ¡¨¡A¦ý¬O²Ä¤G½üªºª÷ÃB¤£¹ï¡A¬O§_§Ú§R±o¤£¹ï¡A½ÐÀ°¬Ý¬Ý¡C

Andy2483

¦^´_ 19# 198188


    https://learn.microsoft.com/zh-t ... pplication.evaluate
±N18¼Ó¤è®× Crr(N, 3) = Crr(N, 3) & ")": Crr(N, 5) = "=" & Crr(N, 3)
§ï¦¨              Crr(N, 3) = Evaluate(Crr(N, 3) & ")")

¥H¤W¬O¥i¥Hª½±µ±o¨ì¼Æ­Èªº¤èªk»PEvaluate() °Ñ¦Òºô­¶
PS:«á¾ÇÅÞ¿è/¤ßºâ³£´¶´¶,¨S¦³¥Î18¼Ó«÷´ê¥X¤½¦¡ªº¤èªk,¸£µ¬·|¥´µ²
ÁÂÁ«e½ú«ü±Ð