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

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

问题出现在AddCalendarMonthHeader（）中 月份单元格应合并、居中并设置样式，但不是。我唯一的想法是范围。Main（）中的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

Public Sub-Main（）
'删除现有工作表
调用RemoveExistingSheets
'添加具有指定名称的新工作表
Dim arrWsNames（）作为字符串
arrWsNames=Split（“b每日，b星期日”，“星期日”）
对于arrWsNames中的每个wsName
AddSheet（wsName）
下一个wsName
'格式化工作表列
对于此工作簿中的每个ws。工作表
如果ws.name“How To”，那么
调用ColWidth（ws）
如果结束
下一个ws
'插入工作表标题
对于此工作簿中的每个ws。工作表
如果ws.name“How To”，那么
调用AddSheetHeaders（ws，2013）
如果结束
下一个ws
'插入日历
对于此工作簿中的每个ws。工作表
如果ws.name“How To”，那么
呼叫添加日历（ws，2013）
如果结束
下一个ws
端接头
公共子添加日历（ByVal ws作为工作表，年份作为整数）
Dim startCol为整数，startRow为整数
Dim month1为整数，month2为整数
月1=1
月2=2
Dim date1作为日期
变暗范围作为范围
Dim rowOffset为整数，colOffset为整数
设置范围=宽度范围（“B1:H1”）
"环环相扣,
对于i=1到12，步骤2
设置范围=范围。偏移量（1，0）
date1=DateSerial（年份，i，1）
'添加月份标题
调用AddCalendarMonthHeader（monthName（i），范围）
'添加工作日标题
设置范围=范围。偏移量（1，0）
调用AddCalendarWeekdaysHeader（ws，范围）
'循环一个月中的所有天
j=1至DaysInMonth（date1）的“向日历添加天数”
将isFirstWeek设置为布尔值：isFirstWeek=True
Dim firstWeekOffset作为整数：firstWeekOffset=工作日（日期序列（年，i，1））
对于j=1至6'周，每月
设置范围=范围。偏移量（1，0）
range.Cells（1,1）.Value=“Week”和j
每周k=1至7'天
如果是第一周的话
isFirstWeek=False
k=工作日（日期序列（年，i，1））
如果结束
下一个k
'退出'k
下一个j
'退出'j'
“为”i“退出
设置范围=范围。偏移量（1，0）
接下来我
端接头
公共子AddCalendarMonthHeader（月为字符串，范围为范围）
射程
合并
.HorizontalAlignment=xlCenter
'.Interior.ColorIndex=34
.Style=“40%-1”
'.Cells（1，1）.Font=10
.Font.Bold=True
.价值=月份
以
端接头
公共子AddCalendarWeekdaysHeader（ws-As工作表，范围为范围）
对于i=1到7
选择案例一
案例1、7
range.Cells（1，i）.Value=“S”
案例2
range.Cells（1，i）.Value=“M”
案例3、5
range.Cells（1，i）.Value=“T”
案例4
range.Cells（1，i）.Value=“W”
案例6
range.Cells（1，i）.Value=“F”
结束选择
range.Cells（1，i）.Style=“40%-1”
接下来我
端接头
公共函数DaysInMonth（date1为Date）为整数
DaysInMonth=CInt（日期序列（年（日期1），月（日期1）+1,1）-日期序列（年（日期1），月（日期1），1））
端函数
'删除除操作说明表以外的所有工作表
公用子删除现有表（）
Application.DisplayAlerts=False
错误转到错误时：
对于此工作簿中的每个ws.Sheets
如果ws.name“How To”，那么
ws.Delete
如果结束
下一个ws
错误：
Application.DisplayAlerts=True
端接头
'添加新工作表以给定名称结尾
公共子地址表（名称为字符串）
ThisWorkbook.Worksheets.Add（在：=ThisWorkbook.Worksheets（ThisWorkbook.Worksheets.Count））之后）。name=name
端接头
'设置图纸列宽
公共子列宽度（ByVal ws作为工作表）
Application.ScreenUpdating=False
错误转到错误时：
我想我会坚持多久
对于i=1到26
ws.Columns（i）.ColumnWidth=4.43
接下来我
错误：
Application.ScreenUpdating=True
端接头
公共子AddSheetHeaders（ByVal ws作为工作表，年份作为整数）
变暗范围作为范围
设置范围=宽度范围（“B1”、“P1”）
射程
合并
.HorizontalAlignment=xlCenter
.Font.ColorIndex=11
.Font.Bold=True
.Font.Size=26
.价值=年
以
端接头

哇，我真的很惊讶这居然能奏效

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

因此，在第二个偏移量之后，

范围

变量只是一个单元格，这意味着它不能被合并。有趣的是，即使重命名了

范围

变量，情况也是如此

现在，仅当调用方法

AddCalendarMonthHeader

中的

.Merge

函数时，才会发生此行为（注释此项表示每次迭代的范围地址都是准确的）

这似乎是使用

直接造成的。Merge

-我这方面有点混乱表明即使是以下代码也会有同样的问题（注意：我将您的

范围

变量重命名为

mrange

）：

---

TL；博士

---

使用

.Merge

会在使用

.Offset

时导致VBA功能异常。我建议您尝试修改代码，使其不使用“合并”（merge）或其他格式策略。

您遇到的问题是，在合并第一个范围后，该范围的长度在偏移时变为一列。那么在

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

        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

    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)