[µo°Ý] ¥ÎVBA¨Ó°õ¦æSUMPRODUCT¦h±ø¥ó²Î­p

b9208

¦U¦ì«e½ú

­ì¨Ï¥ÎSUMPRODUCT¦h±ø¥ó²Î­p¨Ó°õ¦æ¤»­Ó¤ë¸ê®Æ¡A¦ý¤µ¤é»Ý°õ¦æ¤G¦~¸ê®Æ¡A¹Bºâ®É¶¡ªø¡A¤¤³~­×§ï¸ê®Æ¤S­n­«·s¹Bºâ¡Aµ¥«Ý®É¶¡ªø¡C
©Ò¥H½Ð±Ð«e½ú¡A¦p¦ó¥ÎVBA¨Ó°õ¦æSUMPRODUCT¦h±ø¥ó²Î­p¹Bºâ¡C

W1.rar (11.63 KB)

¤U¸ü¦¸¼Æ: 21

2013-4-2 14:10

GBKEE

¦^´_ 1# b9208
¸Õ¸Õ¬Ý

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D(1 To 2) As Object, i As Integer, M As String
   
4.     Dim R As Integer, C As Integer, A As Range
   
5.     Set D(1) = CreateObject("scripting.dictionary")    '¦r¨åª«¥ó
   
6.     Set D(2) = CreateObject("scripting.dictionary")
   
7.     With Sheets("©ú²Ó")
   
8.         i = 6
   
9.         Do While .Cells(i, "d") <> ""
   
10.             M = .Cells(i, "D") & Mid(.Cells(i, "E"), 1, 4) & .Cells(i, "F")
    
11.             D(1)(M) = D(1)(M) + 1                                                               '¥þ³¡
    
12.             M = .Cells(i, "D") & Mid(.Cells(i, "E"), 1, 4) & .Cells(i, "F") & .Cells(i, "L")
    
13.             D(2)(M) = D(2)(M) + 1                                                               '°Ï°ì
    
14.             i = i + 1
    
15.         Loop
    
16.     End With
    
17.      With Sheets("²Î­p")
    
18.         For Each A In .Range("F3:J12,F18:J27,F33:J42,F48:J57").Areas                     '­×¥¿¬°§Aªº¥þ³¡ ¤Î °Ï°ì ªº½d³ò
    
19.             With A
    
20.                 For R = 3 To .Rows.Count - 1
    
21.                     For C = 2 To .Columns.Count
    
22.                         If .Cells(1) = "¥þ³¡" Then                  '¥þ³¡
    
23.                             .Cells(R, C) = D(1)(.Cells(R, 1) & Mid(.Cells(1, C), 1, 4) & .Cells(2, C))
    
24.                         Else                                        '°Ï°ì
    
25.                              .Cells(R, C) = D(2)(.Cells(R, 1) & Mid(.Cells(1, C), 1, 4) & .Cells(2, C) & .Cells(1))
    
26.                         End If
    
27.                     Next
    
28.                 Next
    
29.                 For C = 2 To .Columns.Count
    
30.                     .Cells(.Rows.Count, C).FormulaR1C1 = "=SUM(R[-" & .Rows.Count - 3 & "]C:R[-1]C)"  '¤½¦¡
    
31.                     .Cells(.Rows.Count, C) = .Cells(.Rows.Count, C).Value
    
32.                 Next
    
33.         
    
34.             End With
    
35.         Next
    
36.      End With
    
37. End Sub

½Æ»s¥N½X

b9208

¦^´_ 2# GBKEE
«D±`·PÁª©¥D¦^ÂÐ
¤U¦C¸É¥R»¡©ú¡G
1. ¦U¿é¥Xªí®æ¤§¶g¦¸¤Î³æ¦ì¡A¥Ñµ{¦¡¹Bºâ«á¦Û°Ê¥N¥X¡C
2. ¨ÌB4:B13³]©w¿z¿ï³æ¦ì¡A¿é¥X¿z¿ï³æ¦ì¥þ³¡²Î­p¸ê®Æªí¡C¡]¦pÀɮפºQWE,ASD³æ¦ì¡^
3. ¦pªGB18:B21¦³³]©w¿z¿ï°Ï°ì¡A«h¦A¼W¥[¿é¥X¸Ó°Ï°ì²Î­p¸ê®Æªí¡C¡]¦pÀɮפºQWE,ASD³æ¦ì¤§¥_³¡¸ê®Æ¡^
¥H¤W½Ð°Ñ¦Òªþ¥ó

W111.rar (17.22 KB)

¤U¸ü¦¸¼Æ: 7

2013-4-2 23:58

GBKEE

¦^´_ 3# b9208
¸Õ¸Õ¬Ý

1. Option Explicit
   
2. Dim D(1 To 2) As Object, ¶g¦¸ As Object, ²Î­p³æ¦ì As Variant, Ar        'Dim : ¦¹¼Ò²Õªº¨p¥ÎÅܼÆ(¶È¦¹¼Ò²Õ¥i¥Î)
   
3. Sub EX()
   
4.     Dim i As Integer, ii As Integer, M As String, Rng As Range
   
5.     'Dim Rng As Range, M As String
   
6.     'Dim R As Integer, C As Integer
   
7.     Set D(1) = CreateObject("scripting.dictionary")    '¦r¨åª«¥ó
   
8.     Set D(2) = CreateObject("scripting.dictionary")
   
9.     Set ¶g¦¸ = CreateObject("scripting.dictionary")
   
10.     With Sheets("²Î­p")
    
11.         i = Application.CountA(.[b4:b13])
    
12.         ²Î­p³æ¦ì = Join(Application.Transpose(.Range(.[b4], .[b4].Offset(i - 1))), ",")        '²Î­p³æ¦ì=QWE,ASD
    
13.     End With
    
14.     With Sheets("©ú²Ó")
    
15.         i = 6
    
16.         Do While .Cells(i, "D") <> ""
    
17.             ' "," & ²Î­p³æ¦ì & "," -> ,QWE,ASD,
    
18.             If InStr("," & ²Î­p³æ¦ì & ",", "," & .Cells(i, "F") & ",") Then   '¤ñ¹ï¨ì  ,QWE,   ,ASD, .....
    
19.                 ¶g¦¸(.Cells(i, "F").Value) = ¶g¦¸(.Cells(i, "F").Value) & "," & Mid(.Cells(i, "E"), 1, 4)
    
20.                 M = .Cells(i, "D") & Mid(.Cells(i, "E"), 1, 4) & .Cells(i, "F")
    
21.                 D(1)(M) = D(1)(M) + 1                                                               '¥þ³¡
    
22.                 M = .Cells(i, "D") & Mid(.Cells(i, "E"), 1, 4) & .Cells(i, "F") & .Cells(i, "L")
    
23.                 D(2)(M) = D(2)(M) + 1                                                               '°Ï°ì
    
24.             End If
    
25.             i = i + 1
    
26.         Loop
    
27.     End With
    
28.     ²Î­p³æ¦ì = Split(²Î­p³æ¦ì, ",")                                             ' QWE,ASD,ZXC ¸m©ó°}¦C
    
29.     With Sheets("²Î­p")
    
30.         .[F:J].Clear
    
31.         For i = 0 To UBound(²Î­p³æ¦ì)
    
32.             Ar = Array("¥þ³¡", "³æ¦ì", "MON", "TUE", "WED", "THU", "FRI", "SAT", "SUN", "¤p­p")
    
33.             If i = 0 Then
    
34.                 Set Rng = .[F3]
    
35.             Else
    
36.                 Set Rng = .Cells(.Rows.Count, "F").End(xlUp).Offset(6)          '¨C±iªí®æ¶¡¹j¤­¦C
    
37.             End If
    
38.             ¶g¦¸(²Î­p³æ¦ì(i)) = Mid(¶g¦¸(²Î­p³æ¦ì(i)), 2)
    
39.             ¶g¦¸(²Î­p³æ¦ì(i)) = Split(¶g¦¸(²Î­p³æ¦ì(i)), ",")                   '¨ú±o¶g¦¸
    
40.    
    
41.             ªí®æ»s³y Rng, i
    
42.             ªí®æ²Î­p Rng.CurrentRegion
    
43.             
    
44.             For ii = 0 To Application.CountA(.Range("B18:B21")) - 1
    
45.                 Set Rng = .Cells(.Rows.Count, "F").End(xlUp).Offset(6)          '¨C±iªí®æ¶¡¹j¤­¦C
    
46.                 Ar(0) = .[B18].Offset(ii)
    
47.                 ªí®æ»s³y Rng, i
    
48.                 ªí®æ²Î­p Rng.CurrentRegion
    
49.             Next
    
50.     Next
    
51. End With
    
52. End Sub
    
53. Private Sub ªí®æ»s³y(Rng As Range, i As Integer)
    
54.     Rng.Resize(UBound(Ar) + 1).Value = Application.Transpose(Ar)
    
55.     With Rng.Offset(, 1).Resize(1, UBound(¶g¦¸(²Î­p³æ¦ì(i))) + 1)
    
56.         .Value = ¶g¦¸(²Î­p³æ¦ì(i))
    
57.         .Offset(1) = ²Î­p³æ¦ì(i)
    
58.     End With
    
59.     Rng.CurrentRegion.Borders.LineStyle = 1  '®Ø½u
    
60. End Sub
    
61. Private Sub ªí®æ²Î­p(Rng As Range)
    
62.     Dim R As Integer, C As Integer
    
63.     With Rng
    
64.         For R = 3 To .Rows.Count - 1
    
65.             For C = 2 To .Columns.Count
    
66.                 If .Cells(1) = "¥þ³¡" Then                  '¥þ³¡
    
67.                     .Cells(R, C) = D(1)(.Cells(R, 1) & Mid(.Cells(1, C), 1, 4) & .Cells(2, C))
    
68.                 Else                                        '°Ï°ì
    
69.                     .Cells(R, C) = D(2)(.Cells(R, 1) & Mid(.Cells(1, C), 1, 4) & .Cells(2, C) & .Cells(1))
    
70.                 End If
    
71.             Next
    
72.         Next
    
73.         For C = 2 To .Columns.Count
    
74.             .Cells(.Rows.Count, C).FormulaR1C1 = "=SUM(R[-" & .Rows.Count - 3 & "]C:R[-1]C)"  '¤½¦¡
    
75.             .Cells(.Rows.Count, C) = .Cells(.Rows.Count, C).Value
    
76.         Next
    
77.     End With
    
78. End Sub

½Æ»s¥N½X

b9208

¦^´_ 4# GBKEE
«e½ú±z¦n
VBA¸g°õ¦æ´ú¸Õ«á¡Aªí®æ¦ì¸m¤Î¼Æ¾Ú³£¥¿½T¡A
¦ý¨C¶g¼Æ¾Ú³£­«½Æ¥X²{¦hµ§¡C
¨Ò¦p2012¦~«×¦³1201~1251¶g¡A­p51¶gµ§¡A
¦ýµ{¦¡°õ¦æ«á½T²£¥X6000¦hµ§¶g¦¸¸ê®Æ¡C
¤£À´­ì¦]
«D±`·PÁ«ü¾É

GBKEE

¦^´_ 5# b9208
¤W¶ÇÀɮ׬ݬÝ

b9208

¦^´_ 6# GBKEE
Àɮצpªþ¥ó
ÁÂÁÂ

    W04.rar (25.29 KB)

¤U¸ü¦¸¼Æ: 22

2013-4-9 21:12

GBKEE

¦^´_ 7# b9208
­ü¶g¦¸¨S¦³§Ë¦n,§ó¥¿¦p¤U

1. Option Explicit
   
2. Dim D(1 To 2) As Object, ¶g¦¸ As Object, Ar '        'Dim : ¦¹¼Ò²Õªº¨p¥ÎÅܼÆ(¶È¦¹¼Ò²Õ¥i¥Î)
   
3. Sub EX()
   
4.     Dim i As Integer, ii As Integer, M As String, Rng As Range, ²Î­p³æ¦ì As Variant
   
5.     Set D(1) = CreateObject("scripting.dictionary")    '¦r¨åª«¥ó
   
6.     Set D(2) = CreateObject("scripting.dictionary")
   
7.     Set ¶g¦¸ = CreateObject("scripting.dictionary")
   
8.     With Sheets("²Î­p")
   
9.         i = Application.CountA(.[b4:b13])
   
10.         ²Î­p³æ¦ì = Join(Application.Transpose(.Range(.[b4], .[b4].Offset(i - 1))), ",")        '²Î­p³æ¦ì=QWE,ASD
    
11.     End With
    
12.     With Sheets("©ú²Ó")
    
13.         i = 6
    
14.         Do While .Cells(i, "D") <> ""
    
15.             ' "," & ²Î­p³æ¦ì & "," -> ,QWE,ASD,
    
16.             If InStr("," & ²Î­p³æ¦ì & ",", "," & .Cells(i, "F") & ",") Then   '¤ñ¹ï¨ì  ,QWE,   ,ASD, .....
    
17.                
    
18.                 If InStr("," & ¶g¦¸(.Cells(i, "F").Value) & ",", "," & Mid(.Cells(i, "E"), 1, 4)) & "," = 0 Then '²Î­p³æ¦ì: ¤ñ¹ï¶g¦¸¤£¦s¦b, .....
    
19.                     ¶g¦¸(.Cells(i, "F").Value) = IIf(¶g¦¸(.Cells(i, "F").Value) = "", "", ¶g¦¸(.Cells(i, "F").Value) & ",") & Mid(.Cells(i, "E"), 1, 4)
    
20.                 End If
    
21.                
    
22.                 M = .Cells(i, "D") & Mid(.Cells(i, "E"), 1, 4) & .Cells(i, "F")
    
23.                 D(1)(M) = D(1)(M) + 1                                                               '¥þ³¡
    
24.                 M = .Cells(i, "D") & Mid(.Cells(i, "E"), 1, 4) & .Cells(i, "F") & .Cells(i, "L")
    
25.                 D(2)(M) = D(2)(M) + 1                                                               '°Ï°ì
    
26.             End If
    
27.             i = i + 1
    
28.         Loop
    
29.     End With
    
30.     With Sheets("²Î­p")
    
31.         .[F:IQ].Clear
    
32.         For i = 0 To Application.CountA(.Range("B4:B13")) - 1
    
33.             Ar = Array("¥þ³¡", "³æ¦ì", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun", "¤p­p")
    
34.             If i = 0 Then
    
35.                 Set Rng = .[F3]
    
36.             Else
    
37.                 Set Rng = .Cells(.Rows.Count, "F").End(xlUp).Offset(6)          '¨C±iªí®æ¶¡¹j¤­¦C
    
38.             End If
    
39.            
    
40.             ¶g¦¸(.Range("B4").Offset(i).Value) = Split(¶g¦¸(.Range("B4").Offset(i).Value), ",")
    
41.             '¨ú±o²Î­p³æ¦ì¤§¶g¦¸
    
42.    
    
43.             ªí®æ»s³y Rng, .Range("B4").Offset(i)
    
44.             ªí®æ²Î­p Rng.CurrentRegion
    
45.             
    
46.             For ii = 0 To Application.CountA(.Range("B18:B21")) - 1
    
47.                 Set Rng = .Cells(.Rows.Count, "F").End(xlUp).Offset(6)          '¨C±iªí®æ¶¡¹j¤­¦C
    
48.                 Ar(0) = .[B18].Offset(ii)
    
49.                 ªí®æ»s³y Rng, .Range("B4").Offset(i)
    
50.                 ªí®æ²Î­p Rng.CurrentRegion
    
51.             Next
    
52.     Next
    
53. End With
    
54. End Sub
    
55. Private Sub ªí®æ»s³y(Rng As Range, ³æ¦ì As String)
    
56.     Rng.Resize(UBound(Ar) + 1).Value = Application.Transpose(Ar)
    
57.     With Rng.Offset(, 1).Resize(1, UBound(¶g¦¸(³æ¦ì)) + 1)
    
58.         .Value = ¶g¦¸(³æ¦ì)
    
59.         .Offset(1) = ³æ¦ì
    
60.     End With
    
61.     Rng.CurrentRegion.Borders.LineStyle = 1  '®Ø½u
    
62. End Sub
    
63. Private Sub ªí®æ²Î­p(Rng As Range)
    
64.     Dim R As Integer, C As Integer
    
65.     With Rng
    
66.         For R = 3 To .Rows.Count - 1
    
67.             For C = 2 To .Columns.Count
    
68.                 If .Cells(1) = "¥þ³¡" Then                  '¥þ³¡
    
69.                     .Cells(R, C) = D(1)(.Cells(R, 1) & Mid(.Cells(1, C), 1, 4) & .Cells(2, C))
    
70.                 Else                                        '°Ï°ì
    
71.                     .Cells(R, C) = D(2)(.Cells(R, 1) & Mid(.Cells(1, C), 1, 4) & .Cells(2, C) & .Cells(1))
    
72.                 End If
    
73.             Next
    
74.         Next
    
75.         For C = 2 To .Columns.Count
    
76.             .Cells(.Rows.Count, C).FormulaR1C1 = "=SUM(R[-" & .Rows.Count - 3 & "]C:R[-1]C)"  '¤½¦¡
    
77.             .Cells(.Rows.Count, C) = .Cells(.Rows.Count, C).Value
    
78.         Next
    
79.     End With
    
80. End Sub

½Æ»s¥N½X

b9208

¦^´_ 8# GBKEE
GBKEEª©¥D
«D±`·PÁ«ü¾É
°õ¦æok
¦pªGdÄæ¦Ü³Ì«á¤@µ§¸ê®Æ¨ä¤¤¦³ªÅ®æ¡A«h°õ¦æ¤£§¹¾ã¡C
¤µ­×­q¼W¥[§PÂ_   Do While .Cells(i, "D") <> "" Or .Cells(i, "F") <> ""
°õ¦æ´Nok
¥t¤@­×­q±NDo°j°é§ï¦¨For°j°é¡A¤]ok¡C
u = .[d65536].End(xlUp).Row
For i = 6 To u

½Ð±Ð©óExcel 2010¤¤§PÂ_³Ì«á¤@µ§¸ê®Æ¦C¡AÀ³¦p¦ó­×§ï¤U­±¦¡¤l¡C
u = .[d65536].End(xlUp).Row
ÁÂÁ«ü¾É

GBKEE

¦^´_ 9# b9208

1. Sub Ex()
   
2.     Dim U As Long, E As String
   
3.     Select Case Application.Version
   
4.         Case "12.0"
   
5.             E = 2007
   
6.         Case "11.0"
   
7.             E = 2003
   
8.         Case "10.0"
   
9.             E = 2002
   
10.         Case "9.0"
    
11.             E = 2000
    
12.         Case "8.0"
    
13.             E = 97
    
14.         Case "7.0"
    
15.             E = 95
    
16.         Case "5.0"
    
17.             E = "5.0"
    
18.         Case Else
    
19.             E = "¥¼ª¾"
    
20.     End Select
    
21.     With ActiveSheet
    
22.       MsgBox "Excel " & E & " ª©¥»ªºÁ`¦C¼Æ:  " & .Rows.Count
    
23.         U = .Range("d" & .Rows.Count).End(xlUp).Row
    
24.     End With
    
25. End Sub

½Æ»s¥N½X