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

candy516

¦^´_ 21# Hsieh


«e½ú±z¦n¡G
§Ú¬ã¨s¤F³o¦¸±oµ{¦¡½X©M¤§«eªºµ{¦¡½X¦³¦ó¤£¦P¡Aµo²{¤£¦P¤§³B¦b©ó
mystr = A & "," & A.Offset(, 1)d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
Next
End With
k = 1: r = 1
For Each ky In d.keys
y = Left(Split(ky, ",")(1), 4)
With Sheets(y)
½Ð°ÝLeft(A.Offset(, 1), 4)¦³¤°»ò®t§O©O?
¦A½Ð°Ý¦pªG§Ú¥u·Q­nÅã¥Ü¨Æ¥ó¤é«á²Ä¤­¤Ñªº³ø¹S§ÚÀ³¸Ó«ç»ò§ï©O?
(Á|¨Ò¨Ó»¡¡A¨Æ¥ó¤é¬O20041119¡A«h§Ú­n20041123ªº¸ê®Æ(t+4))
§Ú¸Õ¤F¦n¤[ÁÙ¬O¤£¦¨¥\­C!= =
«D±`·PÁÂ!^^

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

candy516

¦^´_ 18# Hsieh


«e½ú±z¦n~
§Ú±N¤@¼Ëªºµ{¦¡½X¤J¥t¥~¤@­ÓÀɮפ¤°õ¦æ¡A¦ý«o¤£¯à¶]¥X¥¿½Tªºµ²ªG!
¹³¬OÀɮפ¤ªºSHEET1¸ÌªºÃÒ¨é¥N½X2801¥L¦b2004¦~¥X²{3¦¸¡A¦ý¥L¶]¥X¨Ó¥u·|¥X²{¤@¦¸!(°õ¦æµ²ªG¦pªþÀɪºSHEET4)
¦pªG§Ú¥u·Q­n¶]¥X¨Æ¥ó¤é«á²Ä¤­¤Ñªº³ø¹S²v(¥]§t¨Æ¥ó¤é·í¤Ñ)¡A½Ð°Ý¬O­n§ï­þ¸Ì©O?
¤£¦n·N«ä¤@ª½³Â·Ð±z!= =
ÁÂÁÂ!

candy516

¦^´_ 18# Hsieh


ÁÂÁ«e½ú!¤SÀ°§Ú¸Ñ¨M¤@­Ó°ÝÃD¤F!
¯uªº«D±`·PÁ±z!
^^

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

candy516

¦^´_ 6# Hsieh


   ½Ð°Ý«e½ú¡G
    ¦pªG§Ú­n±N­ì¥»ªºµ²ªG§ï¦¨ªþÀɨº¼Ëªº¤è¦¡§e²{¡A§ÚÀ³¸Ó§ï­þ­Ó¦a¤èªºµ{¦¡½X©O?(ªþÀɪºSheet2)
¬O³o­Ó¦a¤è¶Ü?
      B1.Copy .Cells(r, k)
      B2.Copy .Cells(r, k + 1)
      Rng.Copy .Cells(r + 2, k)
      Rng1.Copy .Cells(r + 2, k + 1)
ÁÂÁ±z!

candy516

¦^´_ 16# GBKEE


³o¼Ë´N¸òHsieh ©Ò¼gªº¤@¼Ë¤F!
¤@¼Ëªºµ²ªG¡A¦³¤£¦Pªº¼gªk!
VBA¯uªº¬O¤Ó¼F®`¤F!
§ÚÁٻݭn®É¶¡¨Ó¬ã¨s¤@¤U³o¨Çµ{¦¡½X!
¥H«K§Ú¤é«á¥i¥H§ó§ï©Ò­n§ì¨úªº¸ê®Æ!
«e½ú­Ì¯uªº³£«Ü¼F®`­C!
ÁÂÁ±z­ò!

GBKEE

¦^´_ 15# candy516
¸Õ¸Õ¬Ý¬O§_¤@¼Ë

1. Sub Ex()
   
2.     Dim °£®§¤é As Date, ªÑ²¼ As Range, R As Range, Ar(), E As Integer, i As Integer, ii As Integer
   
3.     Sheets("Sheet2").Cells.Clear
   
4.     For E = 2 To Sheets("Sheet1").UsedRange.Rows.Count
   
5.         Set ªÑ²¼ = Sheets("Sheet1").UsedRange.Rows(E).Cells(1)
   
6.         °£®§¤é = Format(Sheets("Sheet1").UsedRange.Rows(E).Cells(2), "0000/00/00")
   
7.         ReDim Ar(1, 0)
   
8.         i = 0
   
9.         ii = 1
   
10.         With Sheets(Year(°£®§¤é) & "")
    
11.             Set ªÑ²¼ = .Rows(1).Find(ªÑ²¼, LOOKAT:=xlPart, LookIn:=xlValues)  '§ä¨ìªÑ²¼¥N¸¹¦WºÙ ¤é³ø¹S²vÄæ¦ì
    
12.             For Each R In .Range("A3:A" & .Range("A3").End(xlDown).Row)     '
    
13.                 If R >= °£®§¤é And R <= °£®§¤é + 14 Then
    
14.                     Ar(0, i) = R
    
15.                     Ar(1, i) = R.Cells(1, ªÑ²¼.Column)
    
16.                     i = i + 1
    
17.                     ReDim Preserve Ar(1, i)  '¼W¥[°}¦Cªººû¼Æ
    
18.                 End If
    
19.             Next
    
20.             If i > 0 Then
    
21.                 If Sheets("Sheet2").Range("IV" & ii).End(xlToLeft).Offset(, 1).Column >= Columns.Count - 1 Then ii = ii + 14
    
22.                 With Sheets("Sheet2").Range("IV" & ii).End(xlToLeft).Offset(, 1) 'Range("IV1")©¹¥ª¦³¸ê®Æªº²Ä¤@­ÓÀx¦s®æ->Offset(, 1) ¦V¥k²¾°Ê¤@Äæ
    
23.                     .Cells(1, 2) = ªÑ²¼
    
24.                     .Cells(2, 1) = "¦~¤ë¤é"
    
25.                     .Cells(2, 2) = "¤é³ø¹S²v"
    
26.                     .Cells(3, 1).Resize(i, 2) = Application.WorksheetFunction.Transpose(Ar)
    
27.                 End With
    
28.             End If
    
29.         End With
    
30.     Next
    
31.     With Sheets("Sheet2")
    
32.         .Columns(1).Delete
    
33.         .Cells.EntireColumn.AutoFit
    
34.         .Cells.EntireRow.AutoFit
    
35.     End With
    
36. End Sub

½Æ»s¥N½X

candy516

¦^´_ 14# GBKEE


¤£¦n·N«ä~¬O§Úªí¹Fªº¤£¹L²M·¡!
§Úªº¶D¨D¬O­n±N¤Q¦~¨CªÑªº¸ê®Æ¥þ³¡§ì¦Ü¤@­Ó·sªºSHEET¤¤!
´N¹³¬OHsieh «e½ú©Ò¼gªºµ{¦¡¨º¼Ë!
Hsieh «e½úªºµ{¦¡¤]¥HÀ°§Ú¸Ñ¨M§Úªº°ÝÃD!
«ÜÁÂÁ±zªºÀ°¦£~^^