Excel VBA范围合并单元格和偏移量
这可以直接复制并粘贴到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 你遇到的问题是，第一个范围合并后，范围的长度成为偏移一列。 所以在那之后，下一个范围就搞砸了。
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)
哇，我真的很惊讶这个作品！ Range是VBA和Excel中的一个关键字，所以我非常惊讶你可以使用它作为variables名而没有问题。
通过添加debugging语句，您可以更轻松地解决这样的问题：
'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
所以在第二个偏移量之后，你的rangevariables只是一个单元格，这意味着它不能被合并。 有趣的是，即使您的rangevariables被重命名，情况也是如此。
现在，只有当你的方法AddCalendarMonthHeader的.Merge函数被调用时才会发生这种行为（对此进行注释显示你的范围地址对于每次迭代都是准确的）。
看来这是直接导致使用.Merge – 在我的部分乱七八糟的指示即使下面的代码仍然会有同样的问题（注意：我把你的rangevariables重新命名为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会导致VBAfunctionexception。 我会build议尝试修改你的代码，不要使用合并，也许亚历山大说或其他格式的策略。