Excel VBA范围合并单元格和偏移量 [英] Excel VBA Range Merge Cells and offset
问题描述
可以将其复制并直接粘贴到excel模块中并运行
This can be copied and pasted directly into excel module and run
问题出在AddCalendarMonthHeader()中月单元格应该合并,居中和设置样式,但不是这样.我唯一的想法是Main()中的range.offset()正在影响它,但我不知道为什么或如何解决它.
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.
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
推荐答案
您遇到的问题是,在合并第一个范围之后,范围的长度就变成了偏移量的一列.所以在那之后,下一个范围就搞砸了.
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)
这篇关于Excel VBA范围合并单元格和偏移量的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!