VBA Sub to create Excel 月中的第几天更改 01-31 到 1 到 31 的工作表

Question

我发现这个 VBA 子程序可以重命名每个月的几天的工作表，但我想更改名称的输出。目前它是 01、02、03、04 .... 30、31。我希望它是 1、2、3、4、...22、...30、31。这是代码。我也可以使用此函数添加 post 字符串，但在少于 10 个值中仍然有前导零。

Function Addth(pNumber As String) As String
'UpdatebyExtendoffice20160628
Select Case CLng(VBA.Right(pNumber, 1))
    Case 1
    Addth = pNumber & "st"
    Case 2
    Addth = pNumber & "nd"
    Case 3
    Addth = pNumber & "rd"
    Case Else
    Addth = pNumber & "th"
End Select
Select Case VBA.CLng(VBA.Right(pNumber, 2))
    Case 11, 12, 13
    Addth = pNumber & "th"
End Select
End Function


Sub DoDays()
    Dim J As Integer
    Dim K As Integer
    Dim sDay As String
    Dim sTemp As String
    Dim iTarget As Integer
    Dim dBasis As Date

    iTarget = 13
    While (iTarget < 1) Or (iTarget > 12)
        iTarget = Val(InputBox("Numeric month?"))
        If iTarget = 0 Then Exit Sub
    Wend

    Application.ScreenUpdating = False
    sTemp = Str(iTarget) & "/1/" & Year(Now())
    dBasis = CDate(sTemp)

    For J = 1 To 31
        sDay = Addth(Format((dBasis + J - 1), "dd"))

        Addth (sDay)


        If Month(dBasis + J - 1) = iTarget Then

            If J <= Sheets.Count Then
                If Left(Sheets(J).Name, 5) = "Sheet" Then
                    Sheets(J).Name = sDay
                Else
                    Sheets.Add.Move after:=Sheets(Sheets.Count)
                    ActiveSheet.Name = sDay
                    If sDay <= 9 Then sDay = Format((dBasis + J - 1), "d")
                End If
            Else
                Sheets.Add.Move after:=Sheets(Sheets.Count)
                ActiveSheet.Name = sDay
            End If
        End If
    Next J

    For J = 1 To (Sheets.Count - 1)
        For K = J + 1 To Sheets.Count
            If Right(Sheets(J).Name, 10) > _
              Right(Sheets(K).Name, 10) Then
                Sheets(K).Move Before:=Sheets(J)

            End If
        Next K
    Next J


    Sheets(1).Activate
    Application.ScreenUpdating = True
End Sub

Answer 1

为了使用 "d" 格式显示日期（即单位数天输出单位数，双数天输出双数）而不是 "dd" 格式（即双一位数和两位数天的数字输出），你应该改变行说

sDay = Addth(Format((dBasis + J - 1), "dd"))

成为

sDay = Addth(Format((dBasis + J - 1), "d"))

您重构的 DoDays 代码可以是：

Sub DoDays()
    Dim J As Long
    Dim sDay As String
    Dim iTarget As Integer
    Dim dBasis As Date

    iTarget = 13
    While (iTarget < 1) Or (iTarget > 12)
        iTarget = Val(InputBox("Numeric month?"))
        If iTarget = 0 Then Exit Sub
    Wend

    Application.ScreenUpdating = False
    'I changed this next line because I live in a dd/mm/yyyy locale, and your
    'existing line was specific to a mm/dd/yyyy locale.  Using DateSerial gets
    'rid of those sort of issues.
    dBasis = DateSerial(Year(Now()), iTarget, 1)

    For J = 1 To 31
        sDay = Addth(Format(dBasis + J - 1, "d"))

        'This line will crash once "sDay" is "1st" because "st" isn't numeric
        'i.e. CLng(VBA.Right(pNumber, 1)) will get upset with it
        '(I assume it was only in your code while you were testing various things.)
        'Addth (sDay)

        If Month(dBasis + J - 1) <> iTarget Then
            Exit For ' No use processing 30 and 31 if no 29th in this month
        End If

        If J <= Worksheets.Count Then
            If Left(Worksheets(J).Name, 5) = "Sheet" Then
                Worksheets(J).Name = sDay
            Else
                Worksheets.Add.Move After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = sDay
            End If
        Else
            Worksheets.Add.Move After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = sDay
        End If
    Next J

    'This loop sorts sheets into alphabetic order, and is not needed because
    ' sheets are desired to be in existing order
    'For J = 1 To (Sheets.Count - 1)
    '    For K = J + 1 To Sheets.Count
    '        If Right(Sheets(J).Name, 10) > _
    '          Right(Sheets(K).Name, 10) Then
    '            Sheets(K).Move Before:=Sheets(J)
    '        End If
    '    Next K
    'Next J

    Worksheets(1).Activate
    Application.ScreenUpdating = True
End Sub

Answer 2

确定一个月有多少天
将那么多工作表添加到工作簿
重命名工作表

注意：我创建了一个从1到31的序数数组。这样，天数将return正确的序数名称。

Sub DoDays2()
    Dim iMonth As Integer, DaysInMonth As Integer, i1stSheet As Integer, x As Integer

    Do
        iMonth = Val(InputBox("Numeric month?"))
        If iMonth = 0 Then
            Exit Sub
        ElseIf iMonth >= 1 And iMonth <= 12 Then
            Exit Do
        End If
    Loop

    DaysInMonth = Day(DateSerial(Year(Now), iMonth + 1, 1) - 1)

    'For some reason the Worksheets are actually inserted before the last Worksheet.
    Worksheets.Add After:=Worksheets(Worksheets.Count), Count:=DaysInMonth
    i1stSheet = Worksheets.Count - DaysInMonth

    For x = 0 To DaysInMonth - 1
        Worksheets(i1stSheet + x).Name = Split("1st 2nd 3rd 4th 5th 6th 7th 8th 9th 10th 11th 12th 13th 14th 15th 16th 17th 18th 19th 20th 21st 22nd 23rd 24th 25th 26th 27th 28th 29th 30th 31st", " ")(x)
    Next

    'Move the worksheet Back
    Worksheets(Worksheets.Count).Move Before:=Worksheets("1st")

End Sub

VBA Sub to create Excel 月中的第几天更改 01-31 到 1 到 31 的工作表

VBA Sub to create Excel Sheets for Days of Month Change 01-31 to 1st to 31st

excel

vba

concat

spreadsheet