- 帖子
- 254
- 主題
- 6
- 精華
- 0
- 積分
- 310
- 點名
- 0
- 作業系統
- W10
- 軟體版本
- Excel 2016
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2019-6-16
- 最後登錄
- 2024-9-23
|
14#
發表於 2020-6-24 06:05
| 只看該作者
本帖最後由 軒云熊 於 2020-6-24 06:08 編輯
n7822123大大 我還是沒辦法 不知道為甚麼 上接不到下 有時候會跑失敗 如果加延遲 又變得很慢
不過延伸下一年問題 解決了 已經不需要先存到儲存格 這方法是可以自動延伸 謝謝n7822123大大
Sub 日期練習()
'Application.ScreenUpdating = False
Range(Cells(2, 1).End(xlToRight), Cells(2, 1).End(xlDown)).Clear
S = 3
E = 1
For F = 1 To 12 '建立範圍
For P = 1 To Day(DateSerial(Year(Now), F + 1, 0))
Cells(S, E) = DateSerial(Year(Now), F, P)
Cells(S - 1, E) = F & "月" & P & "日" & WeekdayName(Weekday(P))
E = E + 1
If P = Day(DateSerial(Year(Now), F + 1, 0)) Then
If F = 12 Then Exit For
S = S + 2
E = 1
End If
Next P
Next F
For E = ActiveWorkbook.Names.Count To 1 Step -1 '清除定義名稱
If ActiveWorkbook.Names(E).Name <> "指定範圍" Then
ActiveWorkbook.Names(E).Delete
End If
Next E
Y = 65
For i = 3 To Cells(3, 1).End(xlDown).Row Step 2 '定義名稱
範圍名稱 = Chr(Y)
Names.Add Name:="第" & 範圍名稱 & "項", RefersTo:=Range(Cells(i, 1), Cells(i, 1).End(xlToRight))
Y = Y + 1
Next i
'Application.Wait Now + TimeValue("00:00:01")
Set AWN = ActiveWorkbook.Names '合併
For R = 1 To AWN.Count
If R <> 1 Then
K = Mid(AWN(R).RefersToR1C1Local, 2, Len(AWN(R))) & ","
Else
K = AWN(R).RefersToR1C1Local & ","
End If
u = u + K
Next R
Names.Add Name:="指定範圍", RefersTo:=Mid(u, 1, Len(u) - 1)
For E = ActiveWorkbook.Names.Count To 1 Step -1 '清除定義名稱
If ActiveWorkbook.Names(E).Name <> "指定範圍" Then
ActiveWorkbook.Names(E).Delete
End If
Next E
For Each G In Range("指定範圍")
D = G.Offset
Select Case DateAdd("d", -1, D) Mod 6 + 1
Case 1 To 4
G.Offset = "上班"
G.Offset.Font.Color = RGB(0, 0, 89)
G.Interior.Color = RGB(150, 201, 123)
Case 5 To 6
G.Offset = "休假"
G.Offset.Font.Color = RGB(114, 0, 55)
G.Offset.Interior.Color = RGB(255, 255, 92)
End Select
Next G
'Application.ScreenUpdating = True
End Sub |
|
發表於 2020-6-17 19:03
| 
