[已解决]填写日期时同时填写日期对应的周次

cunfu2010 · 发表于 2016-4-8 08:31

如题，如何实现附件中创建工作表填写日期、星期时同时在C列填写周次。用weeknum函数调试了，不行，求助

最佳答案

月排行榜 / 总排行榜

dsmch

2016-4-8 08:55

Sub Macro1()
On Error Resume Next
Dim arr, i%, j%
Sheets("设置").Activate
arr = [b2:b13]: y = [a2]
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Name <> "设置" Then sh.Delete
Next
For i = 1 To UBound(arr)
If Sheets("" & arr(i, 1)) Is Nothing Then
With Sheets.Add(after:=Sheets(Sheets.Count))
d = Day(DateSerial(y, i + 1, 0))
.Cells(2, 1) = "日期": .Cells(2, 2) = "星期"
For j = 1 To d
rq = DateSerial(y, i, j)
.Cells(j + 2, 1) = rq
.Cells(j + 2, 2) = "星期" & Replace(Application.Text(Weekday(rq, 2), "[dbnum1]"), "七", "日")
.Cells(j + 2, 3) = DatePart("ww", rq, 2) '每周周一为开始
Next
.Columns.AutoFit
.Name = arr(i, 1)
End With
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

复制代码

跳转到最佳答案楼层

dsmch · 发表于 2016-4-8 08:55

Sub Macro1()
On Error Resume Next
Dim arr, i%, j%
Sheets("设置").Activate
arr = [b2:b13]: y = [a2]
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Name <> "设置" Then sh.Delete
Next
For i = 1 To UBound(arr)
If Sheets("" & arr(i, 1)) Is Nothing Then
With Sheets.Add(after:=Sheets(Sheets.Count))
d = Day(DateSerial(y, i + 1, 0))
.Cells(2, 1) = "日期": .Cells(2, 2) = "星期"
For j = 1 To d
rq = DateSerial(y, i, j)
.Cells(j + 2, 1) = rq
.Cells(j + 2, 2) = "星期" & Replace(Application.Text(Weekday(rq, 2), "[dbnum1]"), "七", "日")
.Cells(j + 2, 3) = DatePart("ww", rq, 2) '每周周一为开始
Next
.Columns.AutoFit
.Name = arr(i, 1)
End With
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

复制代码

爱疯 · 发表于 2016-4-8 09:32

Sub test1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Call test2
Call test3
End Sub

Sub test2()
Dim i
For i = Sheets.Count To 2 Step -1
      Sheets(i).Delete
Next i
End Sub

Sub test3()
Dim A, y, d, s, i, j
y = Sheets(1).Range("a2")
s = VBA.DateSerial(y, 1, 1)

For i = 1 To 12
      With Sheets.Add(after:=Sheets(i))
         .Name = i & "月"
         .Range("a:a").NumberFormat = "yyyy/mm/dd"
         .Range("a:a").ColumnWidth = 11
      End With

      d = Day(VBA.DateSerial(y, i + 1, 0))
      ReDim A(1 To d, 1 To 3)
      For j = 1 To UBound(A)
         A(j, 1) = s
         A(j, 2) = VBA.WeekdayName(VBA.Weekday(s, vbMonday), , 2)
         A(j, 3) = "第" & Format(s, "ww") & "周"
         s = s + 1
      Next j
      [a3].Resize(UBound(A), UBound(A, 2)) = A
Next i
End Sub

2.rar (31.61 KB, 下载次数: 10)

cunfu2010 · 发表于 2016-4-8 11:51

dsmch 发表于 2016-4-8 08:55

谢谢，目标达到了

cunfu2010 · 发表于 2016-4-8 11:52

爱疯发表于 2016-4-8 09:32
Sub test1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

谢谢，感谢版主答复。

cunfu2010 · 发表于 2016-4-10 19:54

dsmch 发表于 2016-4-8 08:55

你好，如果想把创建的日期中含有星期六、星期日的单元格填充红色，怎么实现

dsmch · 发表于 2016-4-10 20:46

Sub Macro1()
On Error Resume Next
Dim arr, i%, j%
Sheets("设置").Activate
arr = [b2:b13]: y = [a2]
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Name <> "设置" Then sh.Delete
Next
For i = 1 To UBound(arr)
If Sheets("" & arr(i, 1)) Is Nothing Then
      With Sheets.Add(after:=Sheets(Sheets.Count))
         d = Day(DateSerial(y, i + 1, 0))
         .Cells(2, 1) = "日期": .Cells(2, 2) = "星期"
         For j = 1 To d
            rq = DateSerial(y, i, j)
            .Cells(j + 2, 1) = rq
            .Cells(j + 2, 2) = "星期" & Replace(Application.Text(Weekday(rq, 2), "[dbnum1]"), "七", "日")
            If Weekday(rq, 2) = 6 Or Weekday(rq, 2) = 7 Then .Cells(j + 2, 2).Interior.ColorIndex = 3
*          .Cells(j + 2, 3) = DatePart("ww", rq, 2) '每周周一为开始
         Next
         .Columns.AutoFit
         .Name = arr(i, 1)
      End With
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

cunfu2010 · 发表于 2016-4-10 20:57

dsmch 发表于 2016-4-10 20:46
Sub Macro1()
On Error Resume Next
Dim arr, i%, j%

谢谢，明白了

		自动登录	找回密码
密码			注册