Can anyone Please help resolve an issue with ReferToRange in my code. I have attached an example.
I am getting a runtime error 1041 application defined or object defined error when the MAIN is called.
I am linking a combobox listfillrange to 3 named ranges depending on the value of a cell. The three ranges are dynamic(have an offset formula).
the combobox is a different sheet than the named ranges
Please help
Sub MAIN()
Dim PT As Range
Dim i As Long
With Sheet3 ' Unique SPP
setNames .Range("a6")
Set PT = .Range("b1")
i = 1
Do Until PT = ""
If .Range("a1").Value = PT.Value Then
On Error Resume Next
Sheet1.ComboBox1.ListFillRange = ThisWorkbook.Names("view" & i).Name
If Err.Number = 1004 Then
MsgBox "not defined name: view" & i
ElseIf Err.Number <> 0 Then
MsgBox "unexpected error: " & Err.Description
End If
On Error GoTo 0
End If
i = i + 1
Set PT = PT.Offset(0, 1)
Loop
End With
End Sub
Sub setNames(theTopLeft As Range)
Dim theName As Name
Dim nameStr As String
Dim theRng As Range
Dim i As Long
Application.DisplayAlerts = False
theTopLeft.CurrentRegion.CreateNames Top:=True, Left:=False, _
Bottom:=False, Right:=False
Application.DisplayAlerts = True
For Each theName In ThisWorkbook.Names
With theName.RefersToRange.Value
For i = .Cells.Count To 1 Step -1
If .Cells(i) <> "" Then Exit For
Next
End With
If i <> 0 Then theName.RefersTo = theName.RefersToRange.Resize(i, 1)
Next
End Sub
It seems to me that your code is a bit more complicated than necessary. So if I'm understanding correctly what you're trying to do, this should fit the bill.
Sub MAIN()
Dim rC As Range
Dim rD As Range
Dim i As Long
Dim s As String
On Error GoTo errTrap
With Sheet3 'change to suit
s = .Range("a1") 'heading to find
Set rD = .Range("A6", .Cells.SpecialCells(xlCellTypeLastCell)) 'data row 6 and down
Set rD = rD.Resize(, 3) '1st 3 columns only, change if required
i = Application.Match(s, rD.Rows(1).Cells, 0) 'find heading
Set rC = rD.Columns(i).Offset(1).Cells 'drop heading from column
Set rC = .Range(rC(1), .Cells(.Rows.Count, rC.Column).End(xlUp)) 'to end of data
' if column contains data, fill combo
If rC(1).Row > rD.Row Then Sheet1.ComboBox1.ListFillRange = .Name & "!" & rC.Address
End With
Exit Sub
errTrap:
If Err.Number = 13 Then
MsgBox "heading not found: " & s
Else
MsgBox "unexpected error: " & Err.Description
End If
End Sub
Related
I want the values in Column D to change depending upon the value in Column A. Some values do not need to be amended at all if the conditions aren't met
Sub Test()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim row As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
I think I have an error in the lines beginning with c.Value = c.Value * .....
I'm new to VBA and just trying to make sense of it
I just provide this variant. It is working with array, so theoretically it is very quick. Probably no need to turn off the screen updating.
Sub test()
Dim lastRow As Long, i As Long
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
Dim vA As Variant 'Represents A2-A lastrow
vA = .Range("A2").Resize(lastRow - 1).Value
Dim vb As Variant 'Represents D2-D lastrow
vb = .Range("D2").Resize(lastRow - 1).Value
i = 0
Dim v As Variant
For Each v In vA
i = i + 1
If v = "Bol" Then
vb(i, 1) = vb(i, 1) * 1.19
ElseIf v = "Amazon" Then
vb(i, 1) = vb(i, 1) * 1.2
End If
Next v
.Range("D2").Resize(lastRow - 1).Value = vb ' Writing the values to the D column
End With
End Sub
You have to forecast and handle all possible conditions. Use this code please:
Sub Test()
Application.ScreenUpdating = False
Dim row As Integer
Dim Lastrow As Long
'I've assumed that you are working on sheet1
Lastrow = Sheets(1).Cells(Rows.Count, "D").End(xlUp).row
If Lastrow > 1 Then
For row = 2 To Lastrow
If Sheets(1).Cells(row, 1).Value = "Bol" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.19
End If
If Sheets(1).Cells(row, 1).Value = "Amazon" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.2
End If
Next
Else
MsgBox ("There is no data at column D")
End If
Application.ScreenUpdating = True
End Sub
There are quite a few ways to go about what you're trying to do. For what it's worth, this is how I would go about it. You had a few additional variables you didn't need, and your 'row' variable wasn't assigned a value at all.
Sub test2()
Dim lastRow As Long, _
i As Long
Application.ScreenUpdating = False
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
For i = 2 To lastRow
If .Cells(i, 1).Value = "Bol" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.19
End If
If .Cells(i, 1).Value = "Amazon" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.2
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
I kept is relatively simple, so hopefully you can follow what's going on. If you have a lot of "If" statements, it may be cleaner to use VBAs "Select Case".
Also the text strings as you have them set up are case sensitive. "Bol" does not equal "bol" maybe that doesn't matter, but something to be aware of. If the string you pass it is "amazon" it will not pass the 'If' test.
Another assumption I made was that your data is on Sheet1. You should get in the habit of fully qualifying your ranges, it will make your life a lot easier as your code gets more complicated.
Last bit, I'm assuming the values in column D are all numbers. If there is text in there, you may run in to problems multiplying it.
Good luck!
You can simplify your code, and make it easier to read, by looping trough column A instead of column D and using the If/ElseIf statement to test each cell for either of the two conditions. By setting your range and defining c as a range variable for each cell in the range, you only have to loop through each cell and test for the two conditions. If the cell contains Bol use the Offset property to multiple the current value in column D by 1.19; ElseIf the cell contains Amazon use the Offset property to multiple the current value in column D by 1.2. Comments provide in the code.
Application.ScreenUpdating = False
'use the With statement to define your workbook and sheet, change as needed
'Note: "ThisWorkbook" identifies the workbook which contains this code
With ThisWorkbook.Sheets("Sheet1")
'Define the range you want to loop through, using the column you want to test
Dim rng As Range: Set rng = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
'Define the variable for each cell-range
Dim c As Range
'loop through each "c" in the range and if one of the conditions are met
For Each c In rng
If c = "Bol" Then
'then use the "Offset property" to modify the value in column D
c.Offset(, 3) = c.Offset(, 3).Value * 1.19
ElseIf c = "Amazon" Then
c.Offset(, 3) = c.Offset(, 3).Value * 1.2
End If
Next c
End With
Application.ScreenUpdating = True
In-Place Modification
All the solutions have one common issue: you can use them only once. If you need to change the values after adding new records (rows) you should consider adding another column with the initial values so the code could be written to identify what has already been changed and what not. But that's for another question.
Your Sub Solution
You actually had only one serious mistake in two-three places.
Instead of row in the If statements you should have used c.Row and you could have removed Dim row As Integer:
Sub Test_Almost_Fixed()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
Additionally after getting rid of the extra Application.ScreenUpdating = False and the Dim startrow As Integer and some further cosmetics, you could have had something like this:
Sub Test_Fixed()
Dim c As Range
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
Application.ScreenUpdating = False
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
A More Complex Sub Solution
Use the following for the ActiveSheet in a standard module (e.g. Module1). For a particular sheet you can place it in a sheet module (e.g. Sheet1) or create a button on the sheet.
Tip: When you have such a simple (short, fast) code and especially when you're using a Button to run it (in a 'one-time operation code'), it is good practice to use a MsgBox at the end of the code to actually know that the code has run and to prevent accidentally pressing the Button more than once.
Option Explicit
Sub Test()
Const Proc As String = "Test"
On Error GoTo cleanError
' Define Constants.
Const FirstRow As Long = 2
Const SourceColumn As Variant = 1 ' e.g. 1 or "A"
Const TargetColumn As Variant = 4 ' e.g. 4 or "D"
Dim Criteria As Variant ' Add more values.
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant ' Add more values.
Multiplier = Array(1.19, 1.2)
' Check if Criteria and Multiplier Arrays have the same number
' of elements (columns).
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
' Write Source and Target Ranges to Source and Target Arrays.
Dim rng As Range
' Define Last Non-Empty Cell.
Set rng = Columns(TargetColumn).Find("*", , xlValues, , , xlPrevious)
' Check if Target Column is empty.
If rng Is Nothing Then Exit Sub
' Check if the row of Last Non-Empty Cell is above FirstRow.
If rng.Row < FirstRow Then Exit Sub
Dim Target As Variant
' Write Target Range to Target Array.
Target = Range(Cells(FirstRow, TargetColumn), rng).Value
Set rng = Nothing
Dim ubST As Long: ubST = UBound(Target)
Dim Source As Variant
' Write Source Range to Source Array.
Source = Cells(FirstRow, SourceColumn).Resize(ubST).Value
' Modify Target Array.
Dim i As Long, j As Long
' Loop through elements (rows) of Source and Target Arrays.
For i = 1 To ubST
' Loop through elements (columns) of Criteria and Multiplier Arrays.
For j = 0 To ubCM
' Check if the value in current element (row) of Source Array
' matches the value of current element (column) in Criteria Array.
If Source(i, 1) = Criteria(j) Then
' Modify value in current element (row) of Target Array
' by multiplying it with the value of current element (column)
' of Multiplier Array.
Target(i, 1) = Target(i, 1) * Multiplier(j)
' Since a match is found, there is no need to loop anymore.
Exit For
End If
Next j
Next i
Erase Source
' Write values of Target Array to Target Range.
Cells(FirstRow, TargetColumn).Resize(ubST).Value = Target
Erase Target
' Inform user.
MsgBox "Data copied.", vbInformation, "Success"
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
End Sub
An Event Solution
To make it automatically change the values in column D for each change of a value in column A you can place the following code into the sheet module (e.g. Sheet1):
Option Explicit
Private Const SOURCE_COLUMN As Variant = 1 ' e.g. 1 or "A"
Private Const TARGET_COLUMN As Variant = 4 ' e.g. 4 or "D"
Private Sub sdfWorksheet_Change(ByVal Target As Range)
Const Proc As String = "Worksheet_Change"
On Error GoTo cleanError
If Intersect(Columns(SOURCE_COLUMN), Target) Is Nothing Then Exit Sub
Const FirstRow As Long = 2
Dim rng As Range
Set rng = Columns(TARGET_COLUMN).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRow Then Exit Sub
Set rng = Cells(FirstRow, SOURCE_COLUMN).Resize(rng.row - FirstRow + 1)
If Intersect(rng, Target) Is Nothing Then Exit Sub
Dim cel As Range
Application.Calculation = xlCalculationManual ' -4135
For Each cel In Target.Cells
TestChange cel
Next cel
CleanExit:
Application.Calculation = xlCalculationAutomatic ' -4105
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
Private Sub TestChange(SourceCell As Range)
Const Proc As String = "TestChange"
On Error GoTo cleanError
Dim Criteria As Variant
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant
Multiplier = Array(1.19, 1.2)
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
Application.ScreenUpdating = False
Dim TargetCell As Range, j As Long
For j = 0 To ubCM
If SourceCell.Value = Criteria(j) Then
Set TargetCell = Cells(SourceCell.row, TARGET_COLUMN)
TargetCell.Value = TargetCell.Value * Multiplier(j)
Exit For
End If
Next j
CleanExit:
Application.ScreenUpdating = True
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
I want to first check my Range for #NA errors and then display the cell addresses containing the error before quitting the Macro. This is what I've done so far.
Now, if there are errors present, I'd like to display a MsgBox warning the user of the error and stop the rest of the program from executing, if however there are none then I'd like for it to move on to the rest of the program
Check for NA error:
For Each c In myRange
If IsError(c) = True Then
Debug.Print c.Address
End If
Next c
MsgBox "Check for errors and run gain"
Exit Sub
'continuation of the program
This one will write all the addresses of the errors in a string and will display them after the code runs:
Sub TestMe()
Dim myRange As Range
Dim myCell As Range
Dim errorList As String
Set myRange = Worksheets(1).Range("A1:C10")
For Each myCell In myRange
If IsError(myCell) Then
errorList = errorList & vbCrLf & myCell.Address
End If
Next
If Len(errorList) > 0 Then
MsgBox errorList
Exit Sub
End If
End Sub
AFter the loop, there is a check for the 1Len(errorList) and if it is bigger than 0, it shows the MsgBox and exits the sub.
I think this will do the trick:
Dim errorArray()
Dim i As Integer
Dim checkArray As Integer
Dim errorString As String
For Each c In myRange
If IsError(c) = True Then
ReDim Preserve errorArray(i)
errorArray(i) = c.Address
i = i + 1
End If
Next c
On Error Resume Next
checkArray = UBound(errorArray)
If Err = 0 Then
errorString = "An error(s) occured in following cell(s):" & Chr(10)
For i = 0 To UBound(errorArray)
errorString = errorString & errorArray(i) & Chr(10)
Next
MsgBox errorString
Exit Sub
End If
Err.Clear
On Error GoTo 0
As per my comment you could also try to use SpecialCells to avoid any iteration:
Sub test()
Dim rng As Range
With Sheet1 'Change according to your sheets CodeName
'Setup your range to check for errors
Set rng = .Range("A1:C4")
'Check if any errors exist and act if they do
If .Evaluate("SUM(IF(ISERROR(" & rng.Address & "),1))") > 0 Then
MsgBox "Still errors in " & rng.SpecialCells(-4123, 16).Address(False, False)
Exit Sub
End If
End With
End Sub
If your cells are not the result of formulas but constants instead, please change SpecialCells(-4123, 16) to SpecialCells(2, 16).
I'm trying to add items from a file saved in path "C:\Users\se72497\Desktop" which contains in the 1st column of the sheet called "Departamentos" a series of values I want to add in the Combobox.
My combobox receive the name of dept.
Private Sub UserForm_Initialize()
Dim filename As Workbook
Set filename = Workbooks.Open("C:\Users\se72497\Desktop\Tablas_Macro.xlsx")
With filename.Sheets("Departamentos")
dept.List = Range("A2", .Range("A" & Rows.Count).End(xlUp).Value)
End With
End Sub
I've tried to execute this code but it returns me a run-time error:
Why vba returns me this error?
The .Value is in the wrong place. (Or you could say that the parenthesis is in the wrong place). Correcting this, you have:
.Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value
With your current code, .Value is within the Range call, so you're trying to use the value of the cell, not the cell itself, as the 2nd argument.
You want it outside.
Otherwise, if the last cell's value is "foo", then your code is equivalent to
Range("A2", "foo")
which is most certainly not what you want.
So when you click pn your combo box data will get loaded,
' Pre-requisties name the cell A2 with variable rstart
Private Sub UserForm_Initialize()
Dim ws As Worksheet: Set ws = Worksheets("Departamentos")
Dim i As Integer: i = 0
Dim lRow As Long
Dim sAddress As String
On Error GoTo errhandling
If Me.nameofcombobox.Value = vbNullString Then
MsgBox "Select value to continue!"
Else
With ws
lRow = .Range("Departamentos").Rows.Count
'name the cell a2 as rstart
Do Until .Range("rStart").Offset(0, i).Value = Me.nameofcombobox.Value
i = i + 1
Loop
sAddress = .Range("rStart").Offset(0, i - 1).Address
.Range(sAddress & ":" & Left(sAddress, 4) & lRow).Value = .Range(sAddress & ":" & Left(sAddress, 4) & lRow).Value
End With
End If
On Error GoTo 0
MsgBox "Completed without errors", vbInformation, "Success"
FunctionOutput:
Set ws = Nothing
Exit Sub
errhandling:
MsgBox "The following error occurred: " & Err.Description, vbCritical, "Error"
Resume FunctionOutput
End Sub
Option Explicit
Sub LoopThroughValidationList()
Dim lst As Variant
Dim rCl As Range
Dim str As String
Dim iX As Integer
str = Range("B1").Validation.Formula1
On Error GoTo exit_proc:
If Left(str, 1) = "=" Then
str = Right(str, Len(str) - 1)
For Each rCl In Worksheets(Range(str).Parent.Name).Range(str).Cells
Range("B1").Value = rCl.Value
Next rCl
Else
lst = Split(str, ",")
For iX = 0 To UBound(lst)
Range("B1").Value = lst(iX)
Next iX
End If
Exit Sub
exit_proc:
MsgBox "No validation list ", vbCritical, "Error"
End Sub
I am tring to iterate through two data validation lists and copy a range in sheet1 to sheet2 for every iteration. This code iterates through one data validation drop down and doesn't copy the range I want in sheet1.
Change data validation list1 to first item in list
Change data validation list2 to first item in list
Copy range from sheet1 to sheet2, first item in list + first item in list + copied range
Repeat
UPDATE 2018-07-27:
Here are the formulas for my data validation list ='A. Dashboard2'!$B$1:$V$1, ='A. Dashboard'!$B$1:$V$1. And also =OFFSET('A. Dashboard'!$A$1;1;MATCH($F$4;'A. Dashboard'!$A$1:$V$1;0)-1;COUNTA(OFFSET('A. Dashboard'!$A$1;1;MATCH($F$4;'A. Dashboard'!$A$1:$V$1;0)-1;55;1));1)
Untested, written on mobile. See if it works and whether it does what you want.
Code expects that validation list 1 will always begin with an = sign and will be a reference to a range -- and that validation list 2 is a ; delimited list.
Code expects sheets called Dashboard and Result to already exist.
Code will attempt to copy the various ranges (from Dashboard sheet) to a new row on the Result sheet for each item in the validation lists.
Option Explicit
Sub LoopThroughValidationLists()
With thisworkbook
Dim resultsRange as range 'First cell to output to'
Set resultsRange = . worksheets("Result").range("A1")
with .worksheets("Dashboard")
dim list1range as range
set list1range = .range("G3")
dim list2range as range
set list2range = .range("W3")
dim rangeToCopy1 as range
set rangeToCopy1 = .range("K9:K40")
dim rangeToCopy2 as range
set rangeToCopy2 = .range("Z9:Z40")
end with
end with
dim list1formula as string
on error resume next
list1formula = list1range.Validation.Formula1
on error goto 0
dim list2formula as string
on error resume next
list2formula = list2range.Validation.Formula1
on error goto 0
if Len(list1formula) = 0 then
MsgBox("Validation list1 not detected.")
exit sub
elseif ASC(list1formula) <> 61 then
MsgBox("Expected list1 to begin with '='")
exit sub
elseif instrrev(list1formula,"!",-1,vbbinarycompare) > 0 then
List1formula = mid$(list1formula,instrrev(list1formula,"!",-1,vbbinarycompare)+1)
List1formula = replace(list1formula,"$",vbnullstring,1,vbbinarycompare)
End if
if Len(list2formula) = 0 then
MsgBox("Validation list2 not detected.")
exit sub
end if
dim list1items as range
on error resume next
set list1items = thisworkbook.worksheets("A. Dashboard").range(mid$(list1formula,2))
on error goto 0
if list1items is nothing then
MsgBox("Expected validation list1 to refer to a range:" & VBnewline & vbnewline & list1formula)
exit sub
end if
dim list2items() as string
list2items() = split(list2formula, ";")
if list1items.cells.count <> (ubound(list2items) +1) then
MsgBox ("Count of items in list1 is not the same as count of items in list2:" & vbnewline & vbnewline & "List1 = " & list1items.cells.count & " cells " & vbnewline & "List2 = " & (ubound(list2items) +1) & " items")
Exit sub
end if
dim cell as range
dim listIndex as long
application.calculation = xlCalculationManual
application.screenupdating = false
with resultsRange
for each cell in list1range
list1range.value2 = cell.value2
list2range.value2 = list2items(listindex)
list1range.parent.calculate ' Sheet needs to re-calculate '
' Column 1 = list1'
' Column 2 = list2'
' Columns 3 to 34 = K9:K40'
' Columns 35 to 66 = Z9:Z40'
.offset(listindex, 0) = cell.value2 ' Value from list1'
.offset(listindex, 1) = list2items(listindex) ' Value from list2'
rangeToCopy1.copy
'below needs to appear on a new line'
.offset(listIndex, 2).pastespecial paste:=xlPasteValuesAndNumberFormats,
transpose:=True
rangeToCopy2.copy
'below needs to appear on a new line'
.offset(listIndex, 34).pastespecial paste:=xlPasteValuesAndNumberFormats,
transpose:=True
listindex = listindex +1
next cell
application.calculation = xlautomatic
application.screenupdating = true
end with
End Sub
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.
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)
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.