Hsieh

¦^´_ 3# jesscc

1. Sub SourceData_S()
   
2. Dim Ay()
   
3. With Worksheets("¸ê®Æ¨Ó·½")
   
4.     Set Rng = .Range("A3:B3")
   
5.     fs = False
   
6.     If .Range("B3").Value = "" Then
   
7.     MsgBox "µLªk¨ú±oªÑ²¼¦WºÙ,½Ð½T©wªÑ²¼¦WºÙ¤w¶ñ¤JB3Àx¦s®æ", 32, "¸ê®Æ¿ù»~!"
   
8.     Exit Sub
   
9.     End If
   
10.     For Each sh In Sheets 'Àˬd¤u§@ªí¦WºÙ¬O§_¦s¦b
    
11.        If sh.Name = .[B3].Text Then fs = True: Exit For
    
12.     Next
    
13.     If fs = False Then Sheets.Add.Name = .[B3].Text '¦pªG¤u§@ªí¤£¦s¦b´N·s¼W¤u§@ªí
    
14.     ar = Array("A", "C", "I", "P") '»Ý­n´£¨úªºÄæ¦ì
    
15.     ReDim Preserve Ay(s) '¡A±N¼ÐÃD¦C¦s¤J°}¦Cªº²Ä¤@µ§¨ÃÂX¤j°}¦C
    
16.     Ay(s) = Array(.Cells(4, ar(0)).Value, .Cells(4, ar(1)).Value, .Cells(4, ar(2)).Value, .Cells(4, ar(3)).Value)
    
17.     s = s + 1
    
18.     For i = 5 To .Cells(.Rows.Count, 1).End(xlUp).Row '¶i¤J¸ê®Æ°j°é
    
19.        If Weekday(.Cells(i, ar(0)), vbMonday) < 5 Then '§PÂ_¤é´Á¬°¬P´Á´X¡A¬P´Á5¥H«e°õ¦æ
    
20.           ReDim Preserve Ay(s) '±N¸ê®Æ¦s¤J°}¦C
    
21.           Ay(s) = Array(.Cells(i, ar(0)).Text, .Cells(i, ar(1)).Value, .Cells(i, ar(2)).Value, .Cells(i, ar(3)).Value)
    
22.           s = s + 1
    
23.           Else '¬P´Á¤­°õ¦æ
    
24.           ReDim Preserve Ay(s) '±N¸ê®Æ¦s¤J°}¦C
    
25.           Ay(s) = Array(.Cells(i, ar(0)).Text, .Cells(i, ar(1)).Value, .Cells(i, ar(2)).Value, .Cells(i, ar(3)).Value)
    
26.           s = s + 1
    
27.           ReDim Preserve Ay(s) 'Àx¦s¤@­ÓªÅ¥Õ¦C¨ì°}¦C
    
28.           Ay(s) = Array("", "", "", "")
    
29.           s = s + 1
    
30.         End If
    
31.     Next
    
32.     With Sheets(Sheets("¸ê®Æ¨Ó·½").[B3].Text)
    
33.     Rng.Copy .[A1] 'ªÑ²¼¦WºÙ
    
34.     With .Range(.[A3], .Cells(.Rows.Count, 6))
    
35.        .ClearContents '²M°£­ì¨Ó¸ê®Æ
    
36.        .Columns(1).NumberFormat = "yyyy/mm/dd" '³]©wAÄ欰¤é´Á®æ¦¡
    
37.     End With
    
38.     .[A2].Resize(s, 4) = Application.Transpose(Application.Transpose(Ay)) '±N°}¦C­È¼g¤J¤u§@ªí
    
39.     .Columns("A").AutoFit 'AÄæ¦Û°ÊÄæ¼e
    
40.     End With
    
41.     End With
    
42. End Sub

½Æ»s¥N½X

jesscc

·R¦º§A¤F Hsieh ¤j¤j
«ç»ò¨º»ò¼F®`¡A¤~¨S´X¤ÀÄÁªº®É¶¡¡A´N§¹¦¨¤F¡C
§Ú·Q­nªºµ²ªG³£¥X¨Ó¤F¡A¥i¬O¬Ý¤£¤ÓÀ´µ{¦¡ªº¹B§@¡A¹ê¦b¤Ó°ª²`¤F¡C¥i¥H³Â·Ð¤j¤jÁ¿¸Ñ¤@¤U­«ÂI¶Ü?

Hsieh

¦^´_ 1# jesscc

1. Sub SourceData_S()
   
2. Dim Ay()
   
3. With Worksheets("¸ê®Æ¨Ó·½")
   
4.     Set Rng = .Range("A3:B3")
   
5.     fs = False
   
6.     If .Range("B3").Value = "" Then
   
7.     MsgBox "µLªk¨ú±oªÑ²¼¦WºÙ,½Ð½T©wªÑ²¼¦WºÙ¤w¶ñ¤JB3Àx¦s®æ", 32, "¸ê®Æ¿ù»~!"
   
8.     Exit Sub
   
9.     End If
   
10.     For Each sh In Sheets
    
11.        If sh.Name = .[B3].Text Then fs = True: Exit For
    
12.     Next
    
13.     If fs = False Then Sheets.Add.Name = .[B3].Text
    
14.     ar = Array("A", "C", "I", "P")
    
15.     ReDim Preserve Ay(s)
    
16.     Ay(s) = Array(.Cells(4, ar(0)).Value, .Cells(4, ar(1)).Value, .Cells(4, ar(2)).Value, .Cells(4, ar(3)).Value)
    
17.     s = s + 1
    
18.     For i = 5 To .Cells(.Rows.Count, 1).End(xlUp).Row
    
19.        If Weekday(.Cells(i, ar(0)), vbMonday) < 5 Then
    
20.           ReDim Preserve Ay(s)
    
21.           Ay(s) = Array(.Cells(i, ar(0)).Text, .Cells(i, ar(1)).Value, .Cells(i, ar(2)).Value, .Cells(i, ar(3)).Value)
    
22.           s = s + 1
    
23.           Else
    
24.           ReDim Preserve Ay(s)
    
25.           Ay(s) = Array(.Cells(i, ar(0)).Text, .Cells(i, ar(1)).Value, .Cells(i, ar(2)).Value, .Cells(i, ar(3)).Value)
    
26.           s = s + 1
    
27.           ReDim Preserve Ay(s)
    
28.           Ay(s) = Array("", "", "", "")
    
29.           s = s + 1
    
30.         End If
    
31.     Next
    
32.     With Sheets(Sheets("¸ê®Æ¨Ó·½").[B3].Text)
    
33.     Rng.Copy .[A1]
    
34.     With .Range(.[A3], .Cells(.Rows.Count, 6))
    
35.        .ClearContents
    
36.        .Columns(1).NumberFormat = "yyyy/mm/dd"
    
37.     End With
    
38.     .[A2].Resize(s, 4) = Application.Transpose(Application.Transpose(Ay))
    
39.     .Columns("A").AutoFit
    
40.     End With
    
41.     End With
    
42. End Sub

½Æ»s¥N½X