Excel VBA Range Merge Cells and offset

2019-07-19 14:46发布

This can be copied and pasted directly into excel module and run

The issue is in the AddCalendarMonthHeader() The month cell should be merged, centered, and style but it is not. My only thought is the range.offset() in Main() is affecting it but I dont know why or how to fix it.

enter image description here

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

标签: excel vba
2条回答
该账号已被封号
2楼-- · 2019-07-19 15:29

The issue you are having is that after the first range is merged, the length of the range becomes one column on offsetting. So after that, the next ranges are messed up.

    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
.
.
.

To Fix this, all you need to do is change the size of the range before adding the weekdays header

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

enter image description here

查看更多
够拽才男人
3楼-- · 2019-07-19 15:40

Woah, I'm really surprised this works at all! Range is a keyword in VBA and Excel, so it is very surprising to me you are able to use that as a variable name without problems.

You can troubleshoot problems like this a lot easier by adding a debug statement:

        '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

This results in the following:

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

So after the second offset, your range variable is only a single cell, which means it cannot be merged. Interestingly this is the case even if your range variable is renamed.

Now, this behavior ONLY occurs when the .Merge function from your method AddCalendarMonthHeader is invoked (commenting this out shows your range addresses are accurate for each iteration).

It seems this is directly caused by using .Merge - a fair bit of messing around on my part indicates even the following code will still have the same problem (note: I renamed your range variable to 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

Using .Merge causes abnormal functionality with VBA when using .Offset. I would recommend trying to modify your code to not use merge, perhaps as Alexander says or some other formatting strategy.

查看更多
登录 后发表回答