sunnyso

¦^´_ 20# yliu

Ãþ§O°}¦C¥i¥H±qÁ`ªíŪ¨ú, ¤]¥i¥H±q­ì©l¸ê®ÆªíAÄæ§â¤£­«´_ªºÅª¥X¡]¨Ò¦p¦r¨åªk¡^

c_c_lai

¦^´_ 18# yliu
§Ú±N­ì¥» Kimbal ª©¤j´£¨Ñªº­×¥¿µ{¦¡¦b¤©¼W­×¡A
¥H¤Î sunnyso «e½ú´£¨Ñªºµ{¦¡²¤¤©­×¥¿«á¡A¼g¦¨¨â²Õ
®Ä¯q¤£¿ùªº¼Ò²Õ¡A¨Ñ©p¿ï¥Î¡C
A.  ¤§«e´£¨Ñªº¡A§ï¥H°}¦C³B²z (­ì¥»¬O¹ïÀ³¹êÅéÄæ¦ì¤@¤@³B²z)¡A
       ¸g­×¥¿«áªºµ{¦¡½X¡G

1. Sub Ex_Match_Case()         '  Match Case
   
2.     Dim RowsCnt As Long, i As Long, SubTotalAr() As Double
   
3.     Dim t1 As Variant, t2 As Variant, AllType As Variant
   
4.     Dim DataArea As Variant, Atype As Integer
   
5.     Dim lngCurrenMonth As Long, lngCurrValue As Long
   
6. 
   
7.     t1 = Timer
   
8.     Application.ScreenUpdating = False
   
9.     '  Application.Calculation = xlCalculationManual
   
10. 
    
11.     AllType = Array("AÃþ", "BÃþ", "CÃþ", "DÃþ", "EÃþ", "FÃþ", "GÃþ", "HÃþ", "IÃþ", "JÃþ")
    
12.     ReDim SubTotalAr(0 To UBound(AllType), 0 To 16)
    
13.    '  ²M²z¼ƾÚ
    
14.     Sheets("Á`ªí").Activate
    
15.     Sheets("Á`ªí").Range("A3").CurrentRegion.Offset(1, 1).Clear
    
16. 
    
17.     Sheets("­ì©l¸ê®Æ").Activate
    
18.     With Sheets("­ì©l¸ê®Æ")
    
19.         RowsCnt = .Cells(1, 1).CurrentRegion.Rows.Count
    
20.         DataArea = .Range("A2").Resize(RowsCnt - 1, 3)
    
21.         
    
22.         For i = 1 To UBound(DataArea)
    
23.             lngCurrenMonth = 0
    
24.             If IsDate(DataArea(i, 2)) Then
    
25.                 lngCurrenMonth = Month(DataArea(i, 2))                                               '  ·í¦æ¤ë¥÷
    
26.             End If
    
27.             
    
28.             If lngCurrenMonth > 0 Then
    
29.                 lngCurrValue = DataArea(i, 3)
    
30.                         
    
31.                 For Atype = 0 To UBound(AllType)                '  AÃþ To JÃþ
    
32.                     If DataArea(i, 1) = AllType(Atype) Then     '  Jan To Dec
    
33.                         SubTotalAr(Atype, lngCurrenMonth - 1) = SubTotalAr(Atype, lngCurrenMonth - 1) + lngCurrValue
    
34.                         SubTotalAr(Atype, 12) = SubTotalAr(Atype, 12) + lngCurrValue     '  ²Ö­p
    
35.                         SubTotalAr(Atype, 13 + Int(lngCurrenMonth / 3.2)) = SubTotalAr(Atype, 13 + Int(lngCurrenMonth / 3.2)) + lngCurrValue
    
36.                         '  °£¥H 3.2¡G
    
37.                         '  1 (Int(0.3125)=0)¡A  2 (Int(0.625))=0 )¡A 3 (Int(0.9375))=0 )¡A  '  ²Ä¤@©u
    
38.                         '  4 (Int(1.25))=1)¡A   5 (Int(1.5625))= 1)¡A6 (Int(1.875 ))=1)¡A   '  ²Ä¤G©u
    
39.                         '  7 (Int(2.1875))= 2)¡A8 (Int(2.5))=2 )¡A   9 (Int(2.8125))=2)¡A   '  ²Ä¤T©u
    
40.                         '  10(Int(3.125))=3)¡A  11(Int(3.4375 ))=3)¡A12(Int(3.75))=3)       '  ²Ä¥|©u
    
41.                         '  *************************************************************************************
    
42.                     End If
    
43.                 Next Atype
    
44.             End If
    
45.         Next i
    
46.     End With
    
47.    
    
48.     With Sheets("Á`ªí")
    
49.         .Range("B4").Resize(UBound(AllType) + 1, 17) = SubTotalAr
    
50.         '  RowsCnt = .[A3].End(xlDown).Row
    
51.         ' For i = 2 To 18
    
52.         '      .Cells(RowsCnt, i) = WorksheetFunction.Sum(.Range(Chr(64 + i) & 4 & ":" & Chr(64 + i) & (RowsCnt - 1)))   '  ¦X­p
    
53.         '  Next i
    
54.         .Range("B14:R14").FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    
55.     End With
    
56.    
    
57.     '  Application.Calculation = xlCalculationAutomatic
    
58.     Application.ScreenUpdating = True
    
59.     t2 = Timer
    
60.     '  MsgBox "¯Ó®É" & t2 - t1
    
61.     Sheets("­ì©l¸ê®Æ").[F11] = "¯Ó®É¡G " & CDbl(t2 - t1)
    
62. End Sub

½Æ»s¥N½X

B.  ¸g´ú¸Õ¡A®Ä¯q³Ì¨Îªºµ{¦¡¼Ò²Õ¡G

1. Sub Ex_VBA_Array()          '  VBA Code DataArea Array
   
2.     Dim RowsCnt As Long, m As Long, SubTotalAr() As Double
   
3.     Dim t1 As Variant, t2 As Variant, AllType As Variant
   
4.     Dim DataArea As Variant
   
5.     Dim i%, j%
   
6.    
   
7.     t1 = Timer
   
8.     AllType = Array("AÃþ", "BÃþ", "CÃþ", "DÃþ", "EÃþ", "FÃþ", "GÃþ", "HÃþ", "IÃþ", "JÃþ")
   
9.     ReDim SubTotalAr(0 To UBound(AllType), 0 To 11)
   
10.     Application.ScreenUpdating = False
    
11.    
    
12.     '  ²M²z¼ƾÚ
    
13.     '  Sheets("Á`ªí").Activate
    
14.     Sheets("Á`ªí").Range("A3").CurrentRegion.Offset(1, 1).Clear
    
15.    
    
16.     With Sheets("­ì©l¸ê®Æ")
    
17.         RowsCnt = .Range("A1").CurrentRegion.Rows.Count
    
18.         DataArea = .Range("A2").Resize(RowsCnt - 1, 3)
    
19.         
    
20.         For m = 1 To UBound(DataArea)
    
21.             For i = 0 To UBound(AllType)                '  AÃþ To JÃþ
    
22.                 If DataArea(m, 1) = AllType(i) Then     '  Jan To Dec
    
23.                     SubTotalAr(i, Month(DataArea(m, 2)) - 1) = SubTotalAr(i, Month(DataArea(m, 2)) - 1) + DataArea(m, 3)
    
24.                 End If
    
25.             Next i
    
26.         Next m
    
27.     End With
    
28.    
    
29.     With Sheets("Á`ªí")
    
30.         .Range("B4").Resize(UBound(AllType) + 1, 12) = SubTotalAr
    
31.         .Range("N4:N13").FormulaR1C1 = "=SUM(RC[-12]:RC[-1])"
    
32.         For i = 0 To 3
    
33.             '  .Range(Chr(79 + i) & 4 & ":" & Chr(79 + i) & 13).FormulaR1C1 = "=SUM(RC[-" & (13 - i * 2) & "]:RC[-" & (11 - i * 2) & "])"
    
34.             .Range(Chr(79 + i) & 4).Resize(UBound(AllType) + 1).FormulaR1C1 = "=SUM(RC[-" & (13 - i * 2) & "]:RC[-" & (11 - i * 2) & "])"
    
35.             .Range(Chr(79 + i) & 4).Resize(UBound(AllType) + 1) = .Range(Chr(79 + i) & 4).Resize(UBound(AllType) + 1).Value
    
36.         Next i
    
37.         .Range("B14:R14").FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    
38.     End With
    
39.     Application.ScreenUpdating = True
    
40.     t2 = Timer
    
41.     '  MsgBox "¯Ó®É" & t2 - t1
    
42.     Sheets("­ì©l¸ê®Æ").[F3] = "¯Ó®É¡G " & CDbl(t2 - t1)
    
43. End Sub

½Æ»s¥N½X

¥H¤W¨â²Õ¼Ò²Õ¡A§¡¨Ï¥Î 70 µ§¡B¥H¤Î 52,993 µ§¤§¸ê®Æ (sunnyso «e½ú´£¨Ñ) ´ú¸Õ¹L¡C
©p¥i¥H¦Û¦æ´ú´ú¬Ý¡C

Andy2483

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

°õ¦æ«e:

¤U¸ü (71.4 KB)

2023-4-26 16:44

°õ¦æµ²ªG:

¤U¸ü (150.53 KB)

2023-4-26 16:45

Option Explicit
Sub TEST()
Dim Brr, Crr, Y, i&, j&, T1$, T2$, T3%
Dim Sh1 As Worksheet, Sh2 As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("­ì©l¸ê®Æ"): Set Sh2 = Sheets("Á`ªí")
Brr = Range(Sh1.[C2], Sh1.Cells(Rows.Count, "A").End(3))
Sh2.[B4:R14].ClearContents: Crr = Sh2.[A3:R14]
For i = 1 To UBound(Brr)
   T1 = Brr(i, 1): T2 = Format(Brr(i, 2), "M¤ë"): T3 = Brr(i, 3)
   Y(T1 & "|" & T2) = Y(T1 & "|" & T2) + T3
Next
For i = 2 To UBound(Crr) - 1
   For j = 2 To 13: Crr(i, j) = 0 + Y(Crr(i, 1) & "|" & Crr(1, j)): Next
Next
With Sh2
   .[A3:R14] = Crr
   .[N4:N13] = "=SUM(B4:M4)"
   .[O4:O13] = "=SUM(B4:D4)"
   .[P4:P13] = "=SUM(E4:G4)"
   .[Q4:Q13] = "=SUM(H4:J4)"
   .[R4:R13] = "=SUM(K4:M4)"
   .[B14:R14] = "=SUM(B4:B13)"
End With
Set Y = Nothing: Set Sh1 = Nothing: Set Sh2 = Nothing: Erase Brr, Crr
End Sub