Excel VBA范围合并单元格和偏移量

Question

这个可以直接复制粘贴到excel模块中运行

问题出在 AddCalendarMonthHeader() 月份单元格应合并、居中和设置样式，但事实并非如此。我唯一的想法是 Main() 中的 range.offset() 正在影响它，但我不知道为什么或如何解决它。

Public Sub Main()

    'Remove existing worksheets
    Call RemoveExistingSheets

    'Add new worksheets with specified names
    Dim arrWsNames() As String
    arrWsNames = Split("BDaily,BSaturday", ",")
    For Each wsName In arrWsNames
        AddSheet (wsName)
    Next wsName

    'Format worksheets columns
    For Each ws In ThisWorkbook.Worksheets
        If ws.name <> "How-To" Then
            Call ColWidth(ws)
        End If
    Next ws

    'Insert worksheet header
    For Each ws In ThisWorkbook.Worksheets
        If ws.name <> "How-To" Then
            Call AddSheetHeaders(ws, 2013)
        End If
    Next ws

    'Insert calendars
    For Each ws In ThisWorkbook.Worksheets
        If ws.name <> "How-To" Then
            Call AddCalendars(ws, 2013)
        End If
    Next ws


End Sub











Public Sub AddCalendars(ByVal ws As Worksheet, year As Integer)
    Dim startCol As Integer, startRow As Integer

    Dim month1 As Integer, month2 As Integer
    month1 = 1
    month2 = 2
        Dim date1 As Date
        Dim range As range
        Dim rowOffset As Integer, colOffset As Integer

        Set range = ws.range("B1:H1")

    'Loop through all months
    For i = 1 To 12 Step 2
        Set range = range.Offset(1, 0)
        date1 = DateSerial(year, i, 1)

        'Add month header
        Call AddCalendarMonthHeader(monthName(i), range)

        'Add weekdays header
        Set range = range.Offset(1, 0)
        Call AddCalendarWeekdaysHeader(ws, range)

        'Loop through all days in the month
        'Add days to calendar '        For j = 1 To DaysInMonth(date1)

        Dim isFirstWeek As Boolean: isFirstWeek = True
        Dim firstWeekOffset As Integer: firstWeekOffset = Weekday(DateSerial(year, i, 1))

        For j = 1 To 6 'Weeks in month
            Set range = range.Offset(1, 0)
            range.Cells(1, 1).Value = "Week " & j
            For k = 1 To 7 'Days in week
                If isFirstWeek Then
                    isFirstWeek = False
                    k = Weekday(DateSerial(year, i, 1))
                End If
            Next k
'Exit For 'k
        Next j
'Exit For 'j
'Exit For 'i
        Set range = range.Offset(1, 0)
    Next i
End Sub
Public Sub AddCalendarMonthHeader(month As String, range As range)
    With range
        .Merge
        .HorizontalAlignment = xlCenter
'       .Interior.ColorIndex = 34
        .Style = "40% - Accent1"
        '.Cells(1, 1).Font = 10
        .Font.Bold = True
        .Value = month
    End With
End Sub
Public Sub AddCalendarWeekdaysHeader(ws As Worksheet, range As range)
    For i = 1 To 7
        Select Case i
            Case 1, 7
                range.Cells(1, i).Value = "S"
            Case 2
                range.Cells(1, i).Value = "M"
            Case 3, 5
                range.Cells(1, i).Value = "T"
            Case 4
                range.Cells(1, i).Value = "W"
            Case 6
                range.Cells(1, i).Value = "F"
        End Select
        range.Cells(1, i).Style = "40% - Accent1"
    Next i
End Sub
Public Function DaysInMonth(date1 As Date) As Integer
    DaysInMonth = CInt(DateSerial(year(date1), month(date1) + 1, 1) - DateSerial(year(date1), month(date1), 1))
End Function








'Remove all sheets but the how-to sheet
Public Sub RemoveExistingSheets()
    Application.DisplayAlerts = False
    On Error GoTo Error:
    For Each ws In ThisWorkbook.Sheets
        If ws.name <> "How-To" Then
            ws.Delete
        End If
    Next ws

Error:
Application.DisplayAlerts = True
End Sub
'Add a new sheet to end with given name
Public Sub AddSheet(name As String)
    ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)).name = name
End Sub
'Set sheet column widths
Public Sub ColWidth(ByVal ws As Worksheet)
    Application.ScreenUpdating = False
    On Error GoTo Error:
        Dim i As Long
        For i = 1 To 26
           ws.Columns(i).ColumnWidth = 4.43
        Next i
Error:
    Application.ScreenUpdating = True
End Sub
Public Sub AddSheetHeaders(ByVal ws As Worksheet, year As Integer)
    Dim range As range
    Set range = ws.range("B1", "P1")
    With range
        .Merge
        .HorizontalAlignment = xlCenter
        .Font.ColorIndex = 11
        .Font.Bold = True
        .Font.Size = 26

        .Value = year
    End With
End Sub

Answer 1

您遇到的问题是，在合并第一个范围后，范围的长度在偏移时变为一列。所以在那之后，接下来的范围就搞砸了。

    For i = 1 To 12 Step 2
        Set range = range.Offset(1, 0) ' Range is 7 columns wide

        date1 = DateSerial(year, i, 1)

        'Add month header
        Call AddCalendarMonthHeader(MonthName(i), range) ' We merge and range is now 1 column

        'Add weekdays header
        Set range = range.Offset(1, 0) ' Fix here to make it 7 columns
.
.
.

要解决这个问题，您需要做的就是在添加工作日标题之前更改范围的大小

'Add weekdays header
Set range = range.Offset(1, 0).Resize(1, 7)

Answer 2

哇，我真的很惊讶这完全有效！ Range 是 VBA 和 Excel 中的关键字，所以我很惊讶你能够毫无问题地将它用作变量名。

通过添加调试语句，您可以更轻松地解决此类问题：

        'Add month header
        Debug.Print "Range Address: " & range.Address & vbTab & "i:" & i
        Call AddCalendarMonthHeader(MonthName(i), range)
        Debug.Print "Range updated00: " & range.Address
        
        'Add weekdays header
        Debug.Print "Range updated0: " & range.Address
        Set range = range.Offset(1, 0) `<---- this is the line where the Offset loses the entire row
        Debug.Print "Range updated1: " & range.Address

这会导致以下结果：

Range Address: $B$2:$H$2    i:1
Range updated00: $B$2:$H$2
Range updated0: $B$2:$H$2
Range updated1: $B$3

所以在第二个偏移量之后，您的range 变量只是一个单元格，这意味着它不能被合并。有趣的是，即使您的 range 变量被重命名也是如此。

现在，只有在调用方法 AddCalendarMonthHeader 中的 .Merge 函数时才会发生此行为（注释掉表明您的范围地址对于每次迭代都是准确的）。

这似乎是由使用 .Merge 直接引起的 - 我的一些混乱表明即使下面的代码仍然也会有同样的问题（注意：我重命名了你的 @987654330 @变量为mrange):

        Debug.Print "Range updated First: " & mrange.Address
        Set mrange = mrange.Offset(1, 0)
        date1 = DateSerial(year, i, 1)
        
        'Add month header
        Debug.Print "Range Address: " & mrange.Address & vbTab & "i:" & i
        Dim mStr As String
        mStr = mrange.Address
        AddCalendarMonthHeader MonthName(i), mrange
        Debug.Print "Range updated00: " & mrange.Address
        
        'Add weekdays header
        Debug.Print "Range updated0: " & mrange.Address
        Set mrange = range(mStr)
        Set mrange = mrange.Offset(1, 0)
        Debug.Print "Range updated1: " & mrange.Address

---

TL;DR

在使用.Offset 时，使用.Merge 会导致VBA 功能异常。我建议尝试修改您的代码以不使用合并，也许正如 Alexander 所说或其他一些格式化策略。