317

b]回復 18# Hsieh

大大好,
上文中恐表達不好, 現附上圖片, 可否把把程式改成圖1星期一星期二類轉換成下圖中單一數字, 一,二,三,四,五,六,日,謝謝, 祝快樂..

下載 (172.29 KB)

2011-6-29 23:09

317

Hsieh大大, 安好..
已把程式轉成 Ar(s) = Array(d, Replace(Format(mydate, "aaa"), "週", "")), 但還是不成功, 原因何解..請大大協助

Sub Ex()

Dim Ar()

   y = [Am1]

   m = Val(ActiveSheet.Name)

   If m < 1 Or m > 12 Then MsgBox "工作表名稱需要符合1~12月": Exit Sub

   d = 1

   mydate = DateSerial(y, m, d)

   Do Until Month(mydate) <> m

     ReDim Preserve Ar(s)

     k = Format(mydate, "aaa")

     Ar(s) = Array(d, Replace(Format(mydate, "aaa"), "週", ""))

     s = s + 1

     d = d + 1

     mydate = DateSerial(y, m, d)

   Loop

   [G2:AK3] = ""

   [G2].Resize(2, s) = Application.Transpose(Ar)

End Sub

Hsieh

回復 22# 317

可能是版本問題
Format的格式用"aaa"在我的電腦上是顯示"週日"
如果你的電腦上顯示是"星期日"
那就將Replace的字串改成"星期"即可
Ar(s) = Array(d, Replace(Format(mydate, "aaa"), "星期", ""))
或
Ar(s) = Array(d, Right(Format(mydate, "aaa"),1))

317

真是大大所說, 版本問題,
在此謝過大大, 祝願快樂, 感恩..

周大偉

Hsieh版主大大,
先行謝過早前於這帖子的回覆, 有一疑問, vba程式中可否變為附件中, 按下按鈕, 同時把12張月份工作表星期及日期變更, 如可以的話, 的確節省了很多時間, 謝謝!!
aa.rar (24.05 KB)

下載次數: 9

2011-10-8 22:44

Hsieh

回復 25# 周大偉

1. Sub Ex()
   
2. Dim y$, Ar(), w$, j%, i%
   
3. y = InputBox("輸入年分", , Year(Date))
   
4. If y = "" Then Exit Sub
   
5. For i = 1 To 12
   
6.    d = Day(DateAdd("m", 1, DateSerial(CInt(y), i, 1)) - 1)
   
7.    ReDim Preserve Ar(1 To 2, 1 To d)
   
8.    For j = 1 To d
   
9.    w = Replace(Format(Weekday(DateSerial(CInt(y), i, j), 2), "aaa"), "週", "")
   
10.       Ar(1, j) = j
    
11.       Ar(2, j) = w
    
12.    Next
    
13.    Sheets(i & "月").[G2:AK3] = ""
    
14.    Sheets(i & "月").[G2].Resize(2, d) = Ar
    
15.    Erase Ar
    
16. Next
    
17. End Sub

複製代碼

oobird

1. Sub Ex()
   
2.     Dim y%, m%, n%, d%
   
3.     y = [am1]
   
4.     For m = 1 To 12
   
5.         With Sheets(m & "月")
   
6.             .[g2:ak3] = ""
   
7.             n = Day(DateSerial(y, m + 1, 1) - 1)
   
8.             ReDim arr(1 To 2, 1 To n)
   
9.             For d = 1 To n
   
10.                 arr(1, d) = d
    
11.                 arr(2, d) = Right(Application.Text(DateSerial(y, m, d), "aaa"), 1)
    
12.             Next
    
13.             .[g2].Resize(2, n) = arr
    
14.         End With
    
15.     Next
    
16. End Sub

複製代碼

aa.rar (25.32 KB)

下載次數: 8

2011-10-8 23:54

周大偉

hsieh大大 oobord大大,
衷心謝過两位版主大大回應,  祝願健康快樂...