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

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

GBKEE

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

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

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

GBKEE

¦^´_ 12# b9208

1. Private Sub ªí®æ²Î­p(Rng As Range)
   
2.     Dim R As Integer, C As Integer
   
3.     With Rng
   
4.         For R = 3 To .Rows.Count - 1
   
5.             For C = 2 To .Columns.Count
   
6.                 If .Cells(1) = "¥þ³¡" Then                  '¥þ³¡
   
7.                     .Cells(R, C) = D(1)(.Cells(R, 1) & Mid(.Cells(1, C), 1, 4) & .Cells(2, C))
   
8.                 Else                                        '°Ï°ì
   
9.                     .Cells(R, C) = D(2)(.Cells(R, 1) & Mid(.Cells(1, C), 1, 4) & .Cells(2, C) & .Cells(1))
   
10.                 End If
    
11.                 '********
    
12.                 If .Cells(R, C) = "" Then .Cells(R, C) = 0   
    
13.                 '********
    
14.             Next
    
15.         Next
    
16.         For C = 2 To .Columns.Count
    
17.             .Cells(.Rows.Count, C).FormulaR1C1 = "=SUM(R[-" & .Rows.Count - 3 & "]C:R[-1]C)"  '¤½¦¡
    
18.             .Cells(.Rows.Count, C) = .Cells(.Rows.Count, C).Value
    
19.         Next
    
20.     End With
    
21. End Sub

½Æ»s¥N½X

GBKEE

¦^´_ 15# b9208
©Ò¦³µ{¦¡½X¤¤
Mid(.Cells(i, "E"), 1, 4)   ­×§ï¬°  .Cells(i, "E")
Mid(.Cells(1, C), 1, 4)    ­×§ï¬°  .Cells(1, C)

1.¥i¤@¤@¦Û¦æ­×§ï
2.Vba µøµ¡«ü¥O ½s¿è->¨ú¥N

GBKEE

¦^´_ 18# b9208
¨º¶g¦¸¼Æ¦r¦p¦ó¨ú±o¤Î¿é¥X !!!
¥h±¼MID: ¨ú[¥Ó½Ð½s¸¹]§¹¥þ¬Û¦P,ÁÙ­nÂkÃþ¨ì¶g¦¸¤¤
½Ð¤W¶Ç½d¨Ò¹Ïªí¬Ý¬Ý

GBKEE

¦^´_ 20# b9208
ªþÀÉ Ex()µ{§Ç¤£¬O 8# ªºEx()µ{§Ç

1. Option Explicit
   
2. Dim D(1 To 3) 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 D(3) = CreateObject("scripting.dictionary")
   
8.     Set ¶g¦¸ = CreateObject("scripting.dictionary")
   
9.     With Sheets("²Î­p")
   
10.         i = Application.CountA(.[b4:b13])
    
11.         ²Î­p³æ¦ì = Join(Application.Transpose(.Range(.[b4], .[b4].Offset(i - 1))), ",")        '²Î­p³æ¦ì=QWE,ASD
    
12.     End With
    
13.     With Sheets("©ú²Ó")
    
14.         i = 6
    
15.         Do While .Cells(i, "D") <> ""
    
16.             ' "," & ²Î­p³æ¦ì & "," -> ,QWE,ASD,
    
17.             If InStr("," & ²Î­p³æ¦ì & ",", "," & .Cells(i, "F") & ",") Then   '¤ñ¹ï¨ì  ,QWE,   ,ASD, .....
    
18.                 M = .Cells(i, "D") & .Cells(i, "E") & .Cells(i, "F") & .Cells(i, "L")
    
19.                 If D(3)(M) = "" Then   ' *** ³o¸Ì§PÂ_4Äæ³£¬Û¦P¬°¤@µ§¸ê®Æ ****
    
20.                     D(3)(M) = 0
    
21.                     If InStr("," & ¶g¦¸(.Cells(i, "F").Value) & ",", "," & Mid(.Cells(i, "E"), 1, 4)) & "," = 0 Then '²Î­p³æ¦ì: ¤ñ¹ï¶g¦¸¤£¦s¦b, .....
    
22.                         ¶g¦¸(.Cells(i, "F").Value) = IIf(¶g¦¸(.Cells(i, "F").Value) = "", "", ¶g¦¸(.Cells(i, "F").Value) & ",") & Mid(.Cells(i, "E"), 1, 4)
    
23.                     End If
    
24.                     M = .Cells(i, "D") & Mid(.Cells(i, "E"), 1, 4) & .Cells(i, "F")
    
25.                     D(1)(M) = D(1)(M) + 1                                                               '¥þ³¡
    
26.                     M = .Cells(i, "D") & Mid(.Cells(i, "E"), 1, 4) & .Cells(i, "F") & .Cells(i, "L")
    
27.                     D(2)(M) = D(2)(M) + 1                                                               '°Ï°ì
    
28.                 End If
    
29.             End If
    
30.             i = i + 1
    
31.         Loop
    
32.     End With
    
33.     With Sheets("²Î­p")
    
34.         .[F:IQ].Clear
    
35.         For i = 0 To Application.CountA(.Range("B4:B13")) - 1
    
36.             Ar = Array("¥þ³¡", "³æ¦ì", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun", "¤p­p")
    
37.             If i = 0 Then
    
38.                 Set Rng = .[F3]
    
39.             Else
    
40.                 Set Rng = .Cells(.Rows.Count, "F").End(xlUp).Offset(6)          '¨C±iªí®æ¶¡¹j¤­¦C
    
41.             End If
    
42.            
    
43.             ¶g¦¸(.Range("B4").Offset(i).Value) = Split(¶g¦¸(.Range("B4").Offset(i).Value), ",")
    
44.             '¨ú±o²Î­p³æ¦ì¤§¶g¦¸
    
45.    
    
46.             ªí®æ»s³y Rng, .Range("B4").Offset(i)
    
47.             ªí®æ²Î­p Rng.CurrentRegion
    
48.             
    
49.             For ii = 0 To Application.CountA(.Range("B18:B21")) - 1
    
50.                 Set Rng = .Cells(.Rows.Count, "F").End(xlUp).Offset(6)          '¨C±iªí®æ¶¡¹j¤­¦C
    
51.                 Ar(0) = .[B18].Offset(ii)
    
52.                 ªí®æ»s³y Rng, .Range("B4").Offset(i)
    
53.                 ªí®æ²Î­p Rng.CurrentRegion
    
54.             Next
    
55.     Next
    
56. End With
    
57. End Sub

½Æ»s¥N½X