[µo°Ý] ¨D§U°}¦C°ÝÃD

K0l1CHEN6

¨D§U°}¦C°ÝÃD¡A¤p§Ì¹Á¸Õ¹L¦ýµLªk¥¿½T¤À²Õ°}¦C¥[Á`¡AÁٽШD¦U¦ì¤j¤j¨ó§U¡AÁÂÁ¡I

1. Sub test()
   
2. 
   
3.     Dim arr, i, j, k, m, n, p
   
4.         arr = [A1].CurrentRegion.Offset(1).Resize(, 9).Value
   
5.     ReDim Sum(UBound(arr, 2)), t(UBound(arr, 2))
   
6.    
   
7.    
   
8.     For i = 1 To UBound(arr, 1) - 1
   
9.    
   
10.         If arr(i, 2) <> arr(i + 1, 2) Then
    
11.         
    
12.             For j = 6 To UBound(arr, 2)
    
13.                 Sum(j) = Sum(j)
    
14.                 Debug.Print Sum(j)
    
15.             Next
    
16.         Else
    
17.             For j = 6 To UBound(arr, 2)
    
18.                 Sum(j) = Sum(j) + arr(i, j)
    
19.                 Debug.Print Sum(j)
    
20.             Next
    
21. 
    
22.         End If
    
23.         
    
24.             If arr(i + 1, 4) = "²Õ¦X§é¦©" Then
    
25.                 For j = p + 1 To i - 1
    
26.                     For k = 6 To UBound(arr, 2)
    
27.                         n = Round(-arr(i + 1, k) / Sum(k) * arr(j, k), 0)
    
28.                         arr(j, k) = arr(j, k) - n
    
29.                         t(k) = t(k) + n
    
30.                     Next
    
31.                 Next
    
32.             
    
33.                 For k = 6 To UBound(arr, 2)
    
34.                     arr(j, k) = arr(j, k) + arr(i + 1, k) + t(k)
    
35.                     Sum(k) = 0: t(k) = 0
    
36.                 Next
    
37.             
    
38.                 i = i + 1: p = i
    
39.             End If
    
40.     Next
    
41.    
    
42.     For i = 1 To UBound(arr, 1) - 1
    
43.         If arr(i, 4) <> "²Õ¦X§é¦©" Then
    
44.             m = m + 1
    
45.             For j = 1 To UBound(arr, 2)
    
46.                 arr(m, j) = arr(i, j)
    
47.             Next
    
48.         End If
    
49.     Next
    
50.    
    
51.     With [l2]
    
52.         .Resize(UBound(arr, 1), UBound(arr, 2)).ClearContents
    
53.         .Resize(m).NumberFormatLocal = "yyyymmdd"
    
54.         .Resize(m, UBound(arr, 2)) = arr
    
55.     End With
    
56.    
    
57. End Sub

½Æ»s¥N½X

Andy2483

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


Option Explicit
Sub TEST()
Dim Brr, Y, R&, i&, j%, T$, K$
Set Y = CreateObject("Scripting.Dictionary")
Sheets("¤u§@ªí2").[A:I].ClearContents
Brr = Range([¤u§@ªí1!I1], [¤u§@ªí1!A65536].End(3))
K = "²Õ¦X§é¦©"
For i = 2 To UBound(Brr)
   T = Brr(i, 4): T = Brr(i, 2) & "|" & IIf(T = K, K, "")
   For j = 6 To 9:  Y(T & j) = Y(T & j) + Brr(i, j):  Next
Next
For i = 2 To UBound(Brr)
   If Brr(i, 4) = K Then GoTo i01
   T = Brr(i, 2) & "|"
   R = R + 1
   For j = 1 To 5: Brr(R + 1, j) = Brr(i, j): Next
   For j = 6 To 9
       Brr(R + 1, j) = Brr(i, j) + Brr(i, j) * (Y(T & K & j) / Y(T & j))
   Next j
i01: Next i
[¤u§@ªí2!A1:I1].Resize(R + 1) = Brr
Set Y = Nothing: Erase Brr
End Sub

Andy2483

¦^´_ 10# ­ã´£³¡ªL


    ÁÂÁ½׾Â,ÁÂÁ«e½ú
«á¾ÇÂǦ¹©«¾Ç²ß«e½úªº¤è®×,¤è®×¾Ç²ß¤ß±oµù¸Ñ¦p¤U,½Ð«e½ú¦A«ü¾É

¸ê®Æªí:

¤U¸ü (206.5 KB)

2023-6-2 16:01

µ²ªGªí:

¤U¸ü (234.77 KB)

2023-6-2 16:01

Sub TEST_A01()
Dim Arr, xD, i&, j%, N&, T$, U&
'¡ô«Å§iÅܼÆ
Set xD = CreateObject("Scripting.Dictionary")
'¡ô¥OxDÅܼƬO ¦r¨å
Sheets("¤u§@ªí2").UsedRange.EntireRow.Delete
'¡ô¥Oªí2¨Ï¥ÎÀx¦s®æ©Ò¦bªº¦C§R°£
Arr = Range([¤u§@ªí1!I1], [¤u§@ªí1!A1].Cells(Rows.Count, 1).End(xlUp))
'¡ô¥OArrÅܼƬO ¤Gºû°}¦C,¥Hªí1ªºA~IÄæÀx¦s®æ­È±a¤J°}¦C¤¤
For i = 2 To UBound(Arr)
'¡ô³]¶¶°j°é
    T = Arr(i, 2) & "|"
    '¡ô¥OTÅܼƬO²Ä2Äæ°}¦C­È³s±µ"|"²Å¸¹ªº·s¦r¦ê
    If Arr(i, 4) = "²Õ¦X§é¦©" Then T = T & "S"
    '¡ô¦pªG²Ä4Äæ°}¦C­È¬O "²Õ¦X§é¦©"¦r¦ê!´N¥OTÅܼƦA³s±µ"S"¦r¤¸
    For j = 6 To 9:  xD(T & j) = xD(T & j) + Arr(i, j):  Next
    '¡ô³]¶¶°j°é!¥OTÅܼƳs±µj°j°é¼Æªº·s¦r¦ê·íkey,
    '¨äitem­È¦U²Ö¥[jÅܼƷíÄ檺Arr°}¦C­È
Next i
'-----------------------------------
For i = 2 To UBound(Arr)
'¡ô³]¶¶°j°é
    If Arr(i, 4) = "²Õ¦X§é¦©" Then GoTo i01
    '¡ô¦pªG²Ä4Äæ°}¦C­È¬O "²Õ¦X§é¦©"¦r¦ê!´N¤£³B²z«áÄò,¸õ¨ìi01¦ì¸mÄ~Äò°õ¦æ
    T = Arr(i, 2) & "|"
    '¡ô¥OTÅܼƬO²Ä2Äæ°}¦C­È³s±µ"|"²Å¸¹ªº·s¦r¦ê,¥["|"¬O¨¾¸U¤@
    N = N + 1
    '¡ô¥ONÅܼƲ֥[1(²Ö¥[µ²ªG¦C¼Æ,¤@¶}©l´N+1¬O¬°¤FªÅ¥X¼ÐÃDªº¦C)
    For j = 1 To 5: Arr(N + 1, j) = Arr(i, j): Next
    '¡ô³]¶¶°j°é!¥OArr°}¦C±q²Ä¤G¦C¶}©l¼g¤Jµ²ªG­È(1~5Äæ)
    For j = 6 To 9
    '¡ô³]¶¶°j°é
        Arr(N + 1, j) = Arr(i, j) + Arr(i, j) * (xD(T & "S" & j) / xD(T & j))
        '¡ô¥O6~9ÄæArr°}¦C­Èµ²ªG¦C¬O
        '°j°é¦C­ÓÄæ­È+ °j°é¦C­ÓÄæ­È*(²Õ¦X§é¦©Á`ª÷ÃB/«D²Õ¦X§é¦©Á`ª÷ÃB)
        '­pºâ²Õ¦X§é¦©«á¥­§¡»ù®æ(¦]¬°²Õ¦X§é¦©­È¬O­t­È,©Ò¥H¬O¥Î¬Û¥[­pºâ)
    Next j
i01: Next i
'-----------------------------------
[¤u§@ªí2!A1:I1].Resize(N + 1) = Arr
'¡ô¥Oªí2¼g¤JArr°}¦C­È,¶W¹Lµ²ªG­Èªº°}¦C­È©¿²¤
End Sub

°a¤ªºµ

¦^´_ 15# K0l1CHEN6

­è­èµo²{ µ²ªG¸ò·Ç¤jªº¤£¤@¼Ë   ½Ð°Ý ¨S¦³§é¦©ªº²Õ§O ­n«ç»òºâ? ¥i§_Á|¦C  §Ú·Qª¾¹Dµª®× ÁÂÁÂ

°a¤ªºµ

¦^´_ 15# K0l1CHEN6
¦³ªÅÀ°§Ú¬Ý¤@¤U ¬O¤£¬O³o¼Ë ÁÂÁÂ

1. Public Sub °}¦C¤À²Õ¥[Á`½m²ß()
   
2. 
   
3. arr = Range(Cells(2, 2).End(xlDown), Cells(2, 2))
   
4. Set xD = CreateObject("Scripting.Dictionary")
   
5. For i = 1 To UBound(arr, 1)
   
6.     For j = 1 To UBound(arr, 2)
   
7.         xD(arr(i, j)) = arr(i, j)
   
8.     Next j
   
9. Next i
   
10. Erase arr
    
11. arr = Range("a1").CurrentRegion
    
12. ReDim Brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    
13. 
    
14. For Each X In xD
    
15.     ReDim Crr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    
16.     If IsArray(T) Then T = ""
    
17.     For A = 1 To UBound(arr, 1)
    
18.         For A1 = 1 To UBound(arr, 2)
    
19.             If arr(A, 2) = X Then
    
20.                 Crr(A, A1) = arr(A, A1)
    
21.             End If
    
22.         Next A1
    
23.     Next A
    
24. 
    
25.     k = 0: k1 = 0: k2 = 0: k3 = 0
    
26.     For A = 2 To UBound(Crr, 1)
    
27.         If Crr(A, 4) = "²Õ¦X§é¦©" Then
    
28.            T = Array(Crr(A, 6), Crr(A, 7), Crr(A, 8), Crr(A, 9))
    
29.         End If
    
30.         If Crr(A, 2) = X Then
    
31.             If Crr(A, 4) <> "²Õ¦X§é¦©" Then
    
32.                k = k + Crr(A, 6)
    
33.                k1 = k1 + Crr(A, 7)
    
34.                k2 = k2 + Crr(A, 8)
    
35.                k3 = k3 + Crr(A, 9)
    
36.             End If
    
37.         End If
    
38.     Next A
    
39.    
    
40.     For A = 2 To UBound(Crr, 1)
    
41.         If Crr(A, 4) <> "²Õ¦X§é¦©" And Crr(A, 4) <> "" Then
    
42.             If Crr(A, 6) <> 0 And Crr(A, 7) <> 0 And Crr(A, 8) <> 0 And Crr(A, 9) <> 0 Then
    
43.                 If IsArray(T) Then
    
44.                     Brr(A - 1, 1) = (T(0) * Round(Crr(A, 6) / k, 3)) + Crr(A, 6)
    
45.                     Brr(A - 1, 2) = (T(1) * Round(Crr(A, 7) / k1, 3)) + Crr(A, 7)
    
46.                     Brr(A - 1, 3) = (T(2) * Round(Crr(A, 8) / k2, 3)) + Crr(A, 8)
    
47.                     Brr(A - 1, 4) = (T(3) * Round(Crr(A, 9) / k3, 3)) + Crr(A, 9)
    
48.                 End If
    
49.             End If
    
50.             If Not IsArray(T) Then
    
51.                 Brr(A - 1, 1) = k
    
52.                 Brr(A - 1, 2) = k1
    
53.                 Brr(A - 1, 3) = k2
    
54.                 Brr(A - 1, 4) = k3
    
55.             End If
    
56.         End If
    
57.     Next A
    
58. Next X
    
59.            
    
60. Set xD = Nothing
    
61. Erase arr, Crr, T
    
62. Range("K2").Resize(UBound(Brr, 1), UBound(Brr, 2)) = ""
    
63. Range("K2").Resize(UBound(Brr, 1), UBound(Brr, 2)) = Brr
    
64.       
    
65. End Sub

½Æ»s¥N½X

javascript:;

K0l1CHEN6

¥t¥~·Q½Ð±Ð¤@¤U¡A¦r¨å©M°}¦Cªº¤è¦¡¶·­n¦p¦ó§P©w­þ¤@­Ó¬O¾A¦X¦Û¤vªº©O¡H

K0l1CHEN6

¦^´_ 12# ­ã´£³¡ªL


   ·PÁ¤j¤j±Ð¾Ç¡A«D±`·PÁ¡I

K0l1CHEN6

¦^´_ 12# ­ã´£³¡ªL


°}¦Cªº¤èªk¡A¤p§Ìµo²{¦pªG¸ê®Æ¦³ªÅ®æªº¸Ü¤£·|³Q§ì¶i°}¦C¸Ì
©Ò¥H¤p§Ì¥Î¤F¤§«e§Oªº¤j¤j±Ðªº¤è¦¡¤S¦A¦¸­×§ï¤F¤@¤U¬°

1.     k = ThisWorkbook.Sheets(1).Cells.Find(What:="*", _
   
2.                 After:=Range("A1"), _
   
3.                 LookAt:=xlPart, _
   
4.                 LookIn:=xlFormulas, _
   
5.                 SearchOrder:=xlByRows, _
   
6.                 SearchDirection:=xlPrevious, _
   
7.                 MatchCase:=False).Row
   
8.                
   
9.     Arr = sh1.Range("A2:K" & k)

½Æ»s¥N½X

­ã´£³¡ªL

¦^´_ 11# K0l1CHEN6


²Õ§O½s¸¹ 654855
654855| > ¥D­nªºÃöÁä¦r---J=6 TO 9--- 654855|6 ~ 654855|9 --- 6~9Äæ¦U¦Û¿W¥ßªº¥[Á`
654855|S > ²Õ¦X§é¦©ªº«eºóÃöÁä¦r----654855|S6 ~ 654855|S9 --- 6~9Äæ²Õ¦X§é¦©ªºª÷ÃB

¦r¨åªºKEYS¥Î¥H¤W¤èªk, §Y¥i°Ï¤À¦U¶µ¥Øªº¥[Á`ª÷ÃB

K0l1CHEN6

¦^´_ 10# ­ã´£³¡ªL

¤£·\¬O¤j¤j¡A¥Îªºµ{¦¡½X¤ñ¤p§Ìºë²³\¦h¡A¦ý·Q­n¸ß°Ý¤@¤U¨Ï¥Î"|"¬O¦]¬°­n°Ï¹j¤£¦PÄæ¦ì¸ê®ÆªºÃö«Y¶Ü¡H