Hsieh

¦^´_ 3# candy516

1. Sub ex()
   
2. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set sht = Sheets.Add(after:=Sheets(1))
   
5. Application.ScreenUpdating = False
   
6. With Sheet1
   
7.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
   
8.       mystr = A & "," & Left(A.Offset(, 1), 4)
   
9.       d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
   
10.    Next
    
11. End With
    
12. k = 1: r = 1
    
13. For Each ky In d.keys
    
14. y = Split(ky, ",")(1)
    
15. With Sheets(y)
    
16. Set C = .Columns("A").Find(d(ky))
    
17. If Not C Is Nothing Then
    
18.    Set B = .Rows(1).Find(Split(ky, ",")(0))
    
19.    Set B1 = .[A1:A2]
    
20.    Set B2 = B.Resize(2, 1)
    
21.    Set Rng = C.Resize(15, 1)
    
22.    Set Rng1 = .Cells(C.Row, B.Column).Resize(15, 1)
    
23.    With sht
    
24.       B1.Copy .Cells(r, k)
    
25.       B2.Copy .Cells(r, k + 1)
    
26.       Rng.Copy .Cells(r + 2, k)
    
27.       Rng1.Copy .Cells(r + 2, k + 1)
    
28.    End With
    
29.    k = IIf(k = 255, 1, k + 2)
    
30.    r = IIf(k = 1, r + 18, r)
    
31.    Else
    
32.    MsgBox "µL¦¹°£Åv¸ê®Æ"
    
33. End If
    
34. End With
    
35. Next
    
36. Application.ScreenUpdating = True
    
37. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 5# candy516
¤é´Á¶¶§Ç¬Ý¿ù¡A­n©¹¤W15¤Ñ¤~¹ï
¶¶«K±NµL¸ê®Æ±ø¥ó§ï¤@¤U

1. Sub ex()
   
2. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set sht = Sheets.Add(after:=Sheets(1))
   
5. Application.ScreenUpdating = False
   
6. With Sheet1
   
7.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
   
8.       mystr = A & "," & Left(A.Offset(, 1), 4)
   
9.       d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
   
10.    Next
    
11. End With
    
12. k = 1: r = 1
    
13. For Each ky In d.keys
    
14. y = Split(ky, ",")(1)
    
15. With Sheets(y)
    
16. Set C = .Columns("A").Find(d(ky))
    
17. Set B = .Rows(1).Find(Split(ky, ",")(0))
    
18. If Not C Is Nothing And Not B Is Nothing Then
    
19. x = Application.Max(3, C.Row - 14)
    
20.    Set B1 = .[A1:A2]
    
21.    Set B2 = B.Resize(2, 1)
    
22.    Set Rng = .Cells(x, 1).Resize(15, 1)
    
23.    Set Rng1 = .Cells(x, B.Column).Resize(15, 1)
    
24.    With sht
    
25.       B1.Copy .Cells(r, k)
    
26.       B2.Copy .Cells(r, k + 1)
    
27.       Rng.Copy .Cells(r + 2, k)
    
28.       Rng1.Copy .Cells(r + 2, k + 1)
    
29.    End With
    
30.    k = IIf(k = 255, 1, k + 2)
    
31.    r = IIf(k = 1, r + 18, r)
    
32.    Else
    
33.    MsgBox "µL¦¹°£Åv¸ê®Æ"
    
34. End If
    
35. End With
    
36. Next
    
37. Application.ScreenUpdating = True
    
38. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 8# candy516


    x = Application.Max(3, C.Row - 14)
¬O¦]¬°­nºâ§ä¨ì¤é´Áªº¦ì¸m©¹¤W14®æªº¦C¸¹
­Y©¹¤W14®æªº¦C¸¹¥u¦³<=3´N­n¥H3§@¬°¶}©l§ì¸ê®Æªº¦C¦ì
©Ò¥H­Y§A­n§ì30¤Ñ¸ê®Æ³oÃä¤]­n§ï
x = Application.Max(3, C.Row - 29)

Hsieh

¦^´_ 17# candy516

1. Sub ex()
   
2. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set sht = Sheets.Add(after:=Sheets(1))
   
5. Application.ScreenUpdating = False
   
6. With Sheet1
   
7.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
   
8.       mystr = A & "," & Left(A.Offset(, 1), 4)
   
9.       d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
   
10.    Next
    
11. End With
    
12. k = 1: r = 1
    
13. For Each ky In d.keys
    
14. y = Split(ky, ",")(1)
    
15. With Sheets(y)
    
16. Set C = .Columns("A").Find(d(ky))
    
17. Set B = .Rows(1).Find(Split(ky, ",")(0))
    
18. If Not C Is Nothing And Not B Is Nothing Then
    
19. x = Application.Max(3, C.Row - 14)
    
20.    Set Rng = .Cells(x, 1).Resize(15, 1)
    
21.    Set Rng1 = .Cells(x, B.Column).Resize(15, 1)
    
22.    With sht
    
23.       Rng.Copy .Cells(r, k)
    
24.       Rng1.Copy .Cells(r, k + 1)
    
25.       .Cells(r, 3) = y & "¦~²Ä" & B.Column - 1 & "µ§"
    
26.    End With
    
27.    r = r + 15
    
28.    Else
    
29.    MsgBox "µL¦¹°£Åv¸ê®Æ"
    
30. End If
    
31. End With
    
32. Next
    
33. Application.ScreenUpdating = True
    
34. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 20# candy516

1. Sub ex()
   
2. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set sht = Sheets.Add(after:=Sheets(1))
   
5. Application.ScreenUpdating = False
   
6. With Sheet1
   
7.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
   
8.       mystr = A & "," & A.Offset(, 1)
   
9.       d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
   
10.    Next
    
11. End With
    
12. k = 1: r = 1
    
13. For Each ky In d.keys
    
14. y = Left(Split(ky, ",")(1), 4)
    
15. With Sheets(y)
    
16. Set C = .Columns("A").Find(d(ky))
    
17. Set B = .Rows(1).Find(Split(ky, ",")(0))
    
18. If Not C Is Nothing And Not B Is Nothing Then
    
19. x = Application.Max(3, C.Row - 5)
    
20.    Set Rng = .Cells(x, 1).Resize(5, 1)
    
21.    Set Rng1 = .Cells(x, B.Column).Resize(5, 1)
    
22.    With sht
    
23.       Rng.Copy .Cells(r, k)
    
24.       Rng1.Copy .Cells(r, k + 1)
    
25.       .Cells(r, 3) = y & "¦~²Ä" & B.Column - 1 & "µ§"
    
26.    End With
    
27.    r = r + 5
    
28.    Else
    
29.    MsgBox "µL¦¹°£Åv¸ê®Æ"
    
30. End If
    
31. End With
    
32. Next
    
33. Application.ScreenUpdating = True
    
34. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 22# candy516


    ¥i¯à¦³2ºØ±¡ªp§a

1. Sub ex()
   
2. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set sht = Sheets.Add(after:=Sheets(1))
   
5. Application.ScreenUpdating = False
   
6. With Sheet1
   
7.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
   
8.       mystr = A & "," & A.Offset(, 1)
   
9.       d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
   
10.       '­Y¬Oª½±µ¥Î¨Æ¥ó«á²Ä4¤Ñ°µ·j´M­È
    
11.       'd(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00")) + 4
    
12.    Next
    
13. End With
    
14. k = 1: r = 1
    
15. For Each ky In d.keys
    
16. y = Left(Split(ky, ",")(1), 4)
    
17. With Sheets(y)
    
18. Set C = .Columns("A").Find(d(ky))
    
19. Set B = .Rows(1).Find(Split(ky, ",")(0))
    
20. If Not C Is Nothing And Not B Is Nothing Then
    
21. x = Application.Max(3, C.Row - 5)
    
22.    '¥Î¨Æ¥ó¤é¦V¤W4®æ¬°¥Ø¼Ð
    
23.    Set Rng = .Cells(x, 1)
    
24.    Set Rng1 = .Cells(x, B.Column)
    
25.    'ª½±µ¥Î¨Æ¥ó«á²Ä4¤Ñ°µ·j´M­È
    
26.    'Set Rng = .Cells(C.Row, 1)
    
27.    'Set Rng1 = .Cells(C.Row, B.Column)
    
28. 
    
29.    With sht
    
30.       Rng.Copy .Cells(r, k)
    
31.       Rng1.Copy .Cells(r, k + 1)
    
32.       .Cells(r, 3) = y & "¦~²Ä" & B.Column - 1 & "µ§"
    
33.    End With
    
34.    r = r + 1 '¥u¦³¤@¤Ñ¸ê®Æ©Ò¥H¥u­n¥[1
    
35.    Else
    
36.    MsgBox "µL" & y & "¦~" & Split(ky, ",")(0) & "¨Æ¥ó¸ê®Æ"
    
37. End If
    
38. End With
    
39. Next
    
40. Application.ScreenUpdating = True
    
41. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 25# candy516

1. Sub ex()
   
2. On Error Resume Next
   
3. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Set sht = Sheets.Add(after:=Sheets(1))
   
6. Application.ScreenUpdating = False
   
7. With Sheet1
   
8.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
   
9.       mystr = A & "," & Left(A.Offset(, 1), 4)
   
10.      '§ASheet1ªºAÄæ¬O¥H¤é´Á®æ¦¡yyyy/m/d¿é¤J¡A¦ý®æ¦¡³]¦¨yyyymmdd¡A©Ò¥H¡A³y¦¨«D¥þ³¡¬°8½X
    
11.    '¥ÎTEXTÄݩʱo¨ì©Ò¨£¦r¦ê
    
12.       d(mystr) = DateValue(Format(A.Offset(, 1).Text, "0000/00/00"))
    
13.       If Err.Number <> 0 Then MsgBox A & A.Offset(, 1)
    
14.    Next
    
15. End With
    
16. k = 1: r = 1
    
17. For Each ky In d.keys
    
18. y = Split(ky, ",")(1)
    
19. With Sheets(y)
    
20. Set C = .Columns("A").Find(d(ky))
    
21. Set B = .Rows(1).Find(Split(ky, ",")(0))
    
22. If Not C Is Nothing And Not B Is Nothing Then
    
23. x = Application.Max(3, C.Row - 14)
    
24.    Set Rng = .Cells(x, 1).Resize(15, 1)
    
25.    Set Rng1 = .Cells(x, B.Column).Resize(15, 1)
    
26.    With sht
    
27.       Rng.Copy .Cells(r, k)
    
28.       Rng1.Copy .Cells(r, k + 1)
    
29.       .Cells(r, 3) = y & "¦~²Ä" & B.Column - 1 & "µ§"
    
30.    End With
    
31.    r = r + 15
    
32.    Else
    
33.    MsgBox "µL¦¹°£Åv¸ê®Æ"
    
34. End If
    
35. End With
    
36. Next
    
37. Application.ScreenUpdating = True
    
38. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 28# candy516

¥¿³W¤Æªí®æ¬O®Ú¥»¸Ñ¨M¤§¹D
¤£¹L±o­n¥ýÀ¿§¹§¾ªÑ³á

¦Ü©óµ{¦¡°ÝÃDÂI¬O¥X¦b
Set C = .Columns("A").Find(d(ky), lookat:=xlWhole)
Set B = .Rows(1).Find(Split(ky, ",")(0), lookat:=xlPart)
¥[¤J·j´M°Ñ¼Æ´N¯à¥¿½T§ä¨ì¸ê®Æ¤F

Hsieh

¦^´_ 32# candy516

°²¦p§A³o¨Ç¸ê®Æ¬O±q¨t²Î¤¤©Îºô¸ôDownloadªº
³o¤w¸g¬O¬J¦¨ªí®æ¡A¦ý¬O³o¼Ëªº¸ê®Æ±Æ¦C¦b¸ê®Æ®w­ì«h¤¤¬»Ä²¤F¤@¦C¬°¤@µ§¸ê®Æªº­ì«h
³o¼Ëªºªí®æ§AµLªk¨Ï¥ÎEXCEL¤º«Øªº¿z¿ï¥\¯à©Î¼Ï¯Ã¤ÀªRªí
¦Ñ®L«e½úªºÀɮפ¤§A·|µo²{¬O±N©Ò¦³¦~«×ªº¸ê®Æ
¨Ì·Ó¤é´Á¡BªÑ²¼¦WºÙ¡B»ù®æ
¤@µ§¤@µ§¦a¦b¦P¤@¤u§@ªí¤¤§e²{
³o¼Ë§A´N«Ü»´©ö¦a¨Ï¥Î¼Ï¯Ã¤ÀªR©Î¬O¥H¿z¿ï¥\¯àÀò±o·Q­nªº¸ê®Æ
©Ò¥H­n§â§Aªºªí®æ¾ã²z¦¨¸ò¦Ñ®L«e½ú¤@¼Ëªº¸ê®Æªí
§Aı±o§A­nªá¦h¤Ö®É¶¡¸òÅé¤O¤~¯à§¹¦¨
©Ò¥H¡A¦pªG§A¬O³vµ§¸ê®ÆKEYªº«Ø¥ß¸ê®Æªí®É
¨º»òª½±µ°µ¦¨¦Ñ®L«e½úªº®æ¦¡¡A¬O¤£¬O´N¥i¥H¤Ö±¼³o­Ó¾ã²zµ{§Ç
³o´N¬O§Ú©Ò»¡À¿§¾ªÑ°Õ!
¦Ñ®L«e½ú¤£ª¾¹DÀ¿¦n¨S?¥L»¡ÁÙ¦b§V¤O«ÝÄò©O