123
返回列表 上一主題 發帖

一個星期天的問題

317

帖子
248 
主題
55 
精華
0 
積分
334 
點名
0  
作業系統
xp 
軟體版本
2003 
閱讀權限
20 
註冊時間
2010-7-24 
最後登錄
2023-2-2 
21# 跳轉到 »
發表於 2011-6-29 23:10 | 只看該作者
b]回復 18# Hsieh

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

TOP

317

帖子
248 
主題
55 
精華
0 
積分
334 
點名
0  
作業系統
xp 
軟體版本
2003 
閱讀權限
20 
註冊時間
2010-7-24 
最後登錄
2023-2-2 
22#
發表於 2011-6-29 23:17 | 只看該作者
本帖最後由 317 於 2011-6-29 23:20 編輯

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

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
246  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-12 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
23#
發表於 2011-6-29 23:33 | 只看該作者

或

本帖最後由 Hsieh 於 2011-6-30 08:09 編輯

回復 22# 317

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

TOP

317

帖子
248 
主題
55 
精華
0 
積分
334 
點名
0  
作業系統
xp 
軟體版本
2003 
閱讀權限
20 
註冊時間
2010-7-24 
最後登錄
2023-2-2 
24#
發表於 2011-6-30 01:28 | 只看該作者
本帖最後由 317 於 2011-6-30 07:25 編輯

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

TOP

周大偉

帖子
250 
主題
59 
精華
0 
積分
313 
點名
0  
作業系統
XP 
軟體版本
2003 
閱讀權限
20 
性別
男 
來自
澳門 
註冊時間
2010-9-11 
最後登錄
2020-1-6 
25#
發表於 2011-10-8 22:45 | 只看該作者
Hsieh版主大大,
先行謝過早前於這帖子的回覆, 有一疑問, vba程式中可否變為附件中, 按下按鈕, 同時把12張月份工作表星期及日期變更, 如可以的話, 的確節省了很多時間, 謝謝!!
aa.rar (24.05 KB)

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
246  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-12 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
26#
發表於 2011-10-8 23:38 | 只看該作者
回復 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
複製代碼
學海無涯_不恥下問

TOP

oobird
　頭銜: 街友一族

超級版主Rank: 8Rank: 8

帖子
1572 
主題
16 
精華
2 
積分
1521 
點名
0  
作業系統
xp 
軟體版本
office 2003 
閱讀權限
150 
性別
男 
註冊時間
2010-5-1 
最後登錄
2016-1-13 

論壇貢獻勳章
27#
發表於 2011-10-8 23:55 | 只看該作者
  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)

TOP

周大偉

帖子
250 
主題
59 
精華
0 
積分
313 
點名
0  
作業系統
XP 
軟體版本
2003 
閱讀權限
20 
性別
男 
來自
澳門 
註冊時間
2010-9-11 
最後登錄
2020-1-6 
28#
發表於 2011-10-9 09:44 | 只看該作者
hsieh大大 oobord大大,
衷心謝過两位版主大大回應,  祝願健康快樂...

TOP

        靜思自在 : 盡多少本份，就得多少本事。
123
返回列表 上一主題