麻辣家族討論版版 - Powered by Discuz! Board

Option Explicit
'工作表模組:雙擊儲存格程式
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Ex Target.Cells(1), Target.Parent
Target.Select
End Sub
Private Sub Ex(Rng As Range, sh As Worksheet)
Dim T_Date, T_Mon As Integer, TE As Date
Dim M As Integer, Week_Ar(), I As Integer
Week_Ar = Array("日", "一", "二", "三", "四", "五", "六")
Do Until IsDate(T_Date)
T_Date = InputBox("請指定日期", , Date)
If T_Date = "" Then Exit Sub
Loop
With sh
.Cells.Clear '清除工作表
.Cells.HorizontalAlignment = xlCenter '儲存格物件的水平對齊模式:置中
.Cells.VerticalAlignment = xlCenter '儲存格物件的垂直對齊模式:置中
End With
With Rng.Resize(, 7) '指定日期的格式
.Merge '合併: .Resize(, 7)
.Font.Size = 30
.Font.Bold = True
.Font.Color = vbBlue
.NumberFormatLocal = "yyyy-m-d"
Rng = T_Date '日期
End With
I = I + 3
For M = -1 To 1
T_Date = DateAdd("M", M, Rng.Cells(1)) '取得指定月份的日期
T_Date = DateSerial(Year(T_Date), Month(T_Date), 1) '指定月份日期的 1號開始
T_Mon = Month(T_Date) '指定的月份
With Rng.Cells(I).Resize(1, 7) '寫入指定月份的格式
.Merge
.Cells = T_Date
.NumberFormatLocal = "yyyy-m"
.Font.Size = 15
.Font.Bold = True
.Font.Color = vbWhite
.Interior.Color = vbBlue
End With
I = I + 1
With Rng.Cells(I).Resize(, 7) '寫入星期的格式
.Cells = Week_Ar
.Interior.ColorIndex = 15
.Range("A1,G1").Font.Color = vbRed
End With
I = I + 1
Do While T_Mon = Month(T_Date) '迴圈的條件:同一個月份
With Rng.Cells(I, Weekday(T_Date))
.Cells = T_Date
.NumberFormatLocal = "D"
If Weekday(T_Date) = 1 Or Weekday(T_Date) = 7 Then .Font.Color = vbRed
End With
If Weekday(T_Date) = 7 And T_Mon = Month(T_Date + 1) Then I = I + 1
T_Date = T_Date + 1 '日期加一天
Loop
I = I + 2
Next
End Sub

複製代碼

Option Explicit
'工作表模組:雙擊儲存格程式
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim aa As Integer
Cells(7, 2).Value = Target.Cells(1, 1) 'copy to B2
'Cells(7, 2).NumberFormatLocal = "G/通用格式"
Ex Cells(7, 2), Target.Parent
'Target.Select
End Sub
Private Sub Ex(Rng As Range, sh As Worksheet)
Dim E As Range
If Rng = "" Then Exit Sub
If IsNumeric(Rng) Then
Sheets("Sheet1").Activate
If Selection.Row > 1 And Selection.Row < 52 And Selection.Column >= 6 And Selection.Column <= 7 Then
Selection.Value = Rng
End If
End If
End Sub

複製代碼

Option Explicit
'工作表模組:雙擊儲存格程式
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Cells(1).Row > 1 And Target.Cells(1).Row < 52 And Target.Cells(1).Column >= 6 And Target.Cells(1).Column <= 7 Then
Sheets("月曆").Activate
End If
End Sub

複製代碼

'工作表模組:雙擊儲存格程式
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Ex Target, Target.Parent
'Sub Ex 的程式碼中
'With Rng.Resize(, 7) '日期的範圍
' .Merge '合併為儲存格
'*** -> Target.Resize(, 7) 合併為儲存格 ****
'*** 原本的位置當你再次,雙擊儲存格,看看有何變化
End Sub

複製代碼