register313

回復 10# g93353

1. Sub YY()
   
2. Rows("2") = ""
   
3. MX = InputBox("請輸入月份數")
   
4. For M = 1 To MX
   
5.   If [A2] = "" Then
   
6.      [A2] = Cells(1, M)
   
7.   Else
   
8.      [IV2].End(xlToLeft).Offset(0, 1) = Cells(1, M)
   
9.   End If
   
10.   First = Cells(1, M) + (7 - Weekday(Cells(1, M), 2))
    
11.   If [IV2].End(xlToLeft) <> First Then
    
12.      [IV2].End(xlToLeft).Offset(0, 1) = First
    
13.   End If
    
14.   Do While Month(First + 7) = Month(Cells(1, M))
    
15.      [IV2].End(xlToLeft).Offset(0, 1) = First + 7
    
16.      First = First + 7
    
17.   Loop
    
18. Next M
    
19. If MX <> 6 Then
    
20.    Cells(1, MX + 1).Resize(1, 6 - MX).Copy [IV2].End(xlToLeft).Offset(0, 1)
    
21. End If
    
22. Range([A2], [IV2].End(xlToLeft)).NumberFormatLocal = "m/d;@"
    
23. End Sub

複製代碼

Hsieh

回復 1# g93353

1. Sub Ex()
   
2. Dim k%, Ar(), j%, s%, ky, d As Object
   
3. k = InputBox("輸入月數", , 3)
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. For Each A In Rows(1).SpecialCells(xlCellTypeConstants)
   
6.    d(Format(A, "yyyy/mm")) = DateValue(Format(A, "yyyy/mm/1"))
   
7. Next
   
8. For Each ky In d.keys
   
9. j = j + 1
   
10. If j <= k Then
    
11.    For i = d(ky) To DateAdd("M", 1, d(ky)) - 1
    
12.    If (Day(i) = 1 Or Weekday(i, vbMonday) = 7) Then
    
13.       ReDim Preserve Ar(s)
    
14.       Ar(s) = i
    
15.       s = s + 1
    
16.    End If
    
17.    Next
    
18. Else
    
19.       ReDim Preserve Ar(s)
    
20.       Ar(s) = d(ky)
    
21.       s = s + 1
    
22. End If
    
23. Next
    
24. Rows(1) = ""
    
25. [A1].Resize(, s) = Ar
    
26. End Sub

複製代碼

hugh0620

回復 12# Hsieh


    H大大~ 小弟有測試過您的程式碼~
    若像樓主有跨年度的情況~
    ex. 若資料從20120101~20131201的話~
    輸入2月份
    程式碼僅會抓取 201201~201202的資料處理~
    因為程式碼並未針對從哪一個年月的資料來處理~
    而是僅處理第一個抓取的月份~

Hsieh

回復 13# hugh0620
基本上樓主的問題有一些不清楚
是要輸入處理幾個月，然後進行欄位重編的話，程式應可行
若是指定那些月份，那就要輸入2個參數，起始月份及處理月數或結束月份
所以，這只是提供另一種思路參考，至於如何符合個人需求，還是要自己動腦