Here is the code that I am using
Sub insert_column_every_other()
Dim colx As Long
Dim H As Worksheet
Set H = Sheets("Sheet1") 'Replace H3 with the sheet that contains your data
For colx = 9 To 1200 Step 2
Call H.Columns(colx).Insert(Shift:=xlToRight)
H.Range(H.Cells(2, colx), H.Cells(21, colx)).FormulaR1C1 = "=
((OFFSET(RC[-1])-(OFFSET(RC[-3]))/(OFFSET(RC[-3]))*SQRT(252))"
Next colx
End Sub
Getting an error in the following line,
H.Range(H.Cells(2, colx), H.Cells(21, colx)).FormulaR1C1 = "=
((OFFSET(RC[-1])-(OFFSET(RC[-3]))/(OFFSET(RC[-3]))*SQRT(252))"
The error is Application-defined error.
The macro will create a column after the 9th column till the 500th column and then in the blank column will calculate the percentage difference of the stock price of two consecutive days so that's why I went with that particular offset formula.
I think this is what you are looking for
Option Explicit
Sub insert_column_every_other()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
Dim i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 9 To 1200 Step 2
ws.Columns(i).Insert
ws.Range(ws.Cells(2, i), ws.Cells(21, i)).Formula = "=(" & ws.Cells(2, i - 1).Address(False, False) & "-" & ws.Cells(2, i - 2).Address(False, False) & ")/(" & ws.Cells(2, i - 2).Address(False, False) & ")*SQRT(252)"
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Related
I would like to change the color of certain text in the cells based on the values in another cells. I have tried using conditional formatting but it does not work since I only wanted to change the color of particular words in the cells. I have googled a few VBA codes as well but still could not find the right one. Is there any VBA Code to enable this?
As shown in the example below (see image), I want to highlight ONLY the dates in Column B and C that match the dates in Column G. The day should remain the same.
For information, the values in Column B and C are formatted as text and the values in G are formatted as date.
Before
and this is basically what I wish for.
After
I have modified code appropriately as per your requirement in the comment.
Sub Change_Text_Color()
Dim Find_Text, Cell, Cell_in_Col_G, LastCell_inColG As Range
Dim StartChar, CharLen, LastUsedRow_inRange, LastUsedRow_inColB, _
LastUsedRow_inColC As Integer
LastUsedRow_inColB = Sheet1.Cells(Rows.count, "B").End(xlUp).Row
LastUsedRow_inColC = Sheet1.Cells(Rows.count, "C").End(xlUp).Row
LastUsedRow_inRange = Application.WorksheetFunction. _
Max(LastUsedRow_inColB, LastUsedRow_inColC)
Set LastCell_inColG = Sheet1.Cells(Rows.count, "G").End(xlUp)
For Each Cell In Range(Sheet1.Cells(2, 2), Cells(LastUsedRow_inRange, 3))
For Each Cell_in_Col_G In Range(Sheet1.Cells(2, 7), LastCell_inColG)
CharLen = Len(Cell_in_Col_G.Text)
Set Find_Text = Cell.Find(what:=Cell_in_Col_G.Text)
If Not Find_Text Is Nothing Then
StartChar = InStr(Cell.Value, Cell_in_Col_G.Text)
With Cell.Characters(StartChar, CharLen)
.Font.Color = RGB(0, 255, 0)
End With
End If
Next
Next
End Sub
Please let me know your feedback on it.
Use Characters:
With Range("a1")
.Characters(Start:=1, Length:=4).Font.Color=0
.Characters(Start:=5, Length:=10.Font.Color=255
End With
colours the first four letters black and the next ten in red.
Ref:
https://learn.microsoft.com/en-us/office/vba/api/excel.characters
I find filtering works well in these scenarios. Assuming that the format of your sheet is as it is in your sample sheets, try the code below:
Sub MarkDatesInCells()
Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet3") '<- Change to the sheet name
Dim iLRToHighlight As Long, iStartChar As Long, iC As Long, iLR As Long
Dim oHighlightRng As Range, oUpdateRng As Range, oRng As Range
Dim sColName As String
' Turn off updating
Application.ScreenUpdating = False
Application.EnableEvents = False
With oWS
' Clear autofilter if exists
If .AutoFilterMode Then .AutoFilterMode = False
' Loop through all values specified in column G
iLRToHighlight = .Range("G" & .Rows.Count).End(xlUp).Row
For Each oHighlightRng In .Range("G2:G" & iLRToHighlight)
' Loop through column B and C
For iC = 2 To 3
' Set autofilter based on the value in column G
.UsedRange.AutoFilter iC, "=*" & oHighlightRng.Value
' Loop through all visible rows
iLR = .Cells(.Rows.Count, iC).End(xlUp).Row
If iLR > 1 Then
sColName = Left(Replace(.Cells(1, iC).Address, "$", ""), 1)
Set oUpdateRng = .Range(sColName & "2:" & sColName & iLR).SpecialCells(xlCellTypeVisible)
' Update each cell text
For Each oRng In oUpdateRng
iStartChar = InStr(1, oRng.Value, "- ", vbTextCompare) + 2
oRng.Characters(Start:=iStartChar, Length:=Len(oHighlightRng.Value)).Font.Color = 255
Next
End If
.AutoFilterMode = False
Next
Next
End With
' Turn on updating
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
EDIT
Based on your requirement to have this solution for a sheet with a table connected to a database, try the below code. I don't have a database that I can test the below code on so you might have to tinker with it a bit to get it right (i.e. the text that is highlight)
Sub MarkDatesInCellsInATable()
Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet4") '<- Change to the sheet name
Dim iLRToHighlight As Long, iStartChar As Long, iC As Long, iLR As Long
Dim oHighlightRng As Range, oUpdateRng As Range, oRng As Range
Dim sColName As String
Dim oTable As ListObject: Set oTable = oWS.ListObjects("Table_ExceptionDetails.accdb") '<- Change to the table name
Application.ScreenUpdating = False
Application.EnableEvents = False
With oWS
' Reset autofilter
oTable.Range.AutoFilter
' Loop through all values specified in column G
iLRToHighlight = .Range("G" & .Rows.Count).End(xlUp).Row
For Each oHighlightRng In .Range("G2:G" & iLRToHighlight)
' Loop through column B and C
For iC = 2 To 3
' Set autofilter based on the value in column G
oTable.Range.AutoFilter iC, "=*" & oHighlightRng.Value & "*"
' Loop through all visible rows
iLR = .Cells(.Rows.Count, iC).End(xlUp).Row
If iLR > 1 Then
sColName = Left(Replace(.Cells(1, iC).Address, "$", ""), 1)
Set oUpdateRng = .Range(sColName & "2:" & sColName & iLR).SpecialCells(xlCellTypeVisible)
' Update each cell text
For Each oRng In oUpdateRng
iStartChar = InStr(1, oRng.Value, "- ", vbTextCompare) + 2
oRng.Characters(Start:=iStartChar, Length:=Len(oHighlightRng.Value)).Font.Color = 255
Next
End If
oTable.Range.AutoFilter
Next
Next
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
I am working on a project in which I am comparing column D with column C of sheet("Backend") and the difference is shown in column E (in %). I'd like to highlight the % difference (column E) in RED color, where the difference is less than -10.00% and greater than 10.00%. Then would like to copy those items from column B corresponding each highlighted cell and paste it in sheet("UPDATER") beneath cell A7.
Attached is the screenshot for your reference
Sub check_date()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wsData As Worksheet, Datasht As Worksheet, lRow As Integer
Set wsData = Sheets("UPDATER")
Set Datasht = Sheets("Backend")
lRow = Datasht.Cells(Rows.Count, 13).End(xlUp).Row
wsData.Range("M8:M" & lRow).Interior.ColorIndex = xlNone
wsData.Range("M8:M" & lRow).FormatConditions.Add Type:=xlExpression, Formula1:="=AND(M8>=EOMONTH(TODAY(),-2)+1,M8<EOMONTH(TODAY(),-1))"
wsData.Range("M8:M" & lRow).FormatConditions(wsData.Range("M8:M" & lRow).FormatConditions.Count).SetFirstPriority
With wsData.Range("M8:M" & lRow).FormatConditions(1).Interior
.Color = RGB(255, 255, 0)
.TintAndShade = 0
End With
wsData.Range("M8:M" & lRow).FormatConditions(1).StopIfTrue = False
Range("M8").Select
End Sub
Here's what I got. It's a bit of a drastic change but I'm hoping this is actually what you're going for.
Sub formatcondition()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wsData As Worksheet, Datasht As Worksheet, lRow As Integer, My_Range As Range, i As Integer, iRow As Integer, cell As Variant, RowNum As Long, lRowUpdater As Long
Set wsData = Sheets("UPDATER")
Set Datasht = Sheets("Backend")
lRow = Datasht.Cells(Rows.Count, 5).End(xlUp).Row
lRowUpdater = wsData.Cells(Rows.Count, 1).End(xlUp).Row
RowNum = 8 'setting the first row in the UPDATER sheet
Datasht.Range("E1:E" & lRow).Interior.ColorIndex = xlNone 'Reset the color before running
wsData.Range("A8:D" & lRowUpdater + 8).ClearContents 'clear your updater sheet. Remove if not needed.
For i = 1 To lRow
On Error GoTo Continue
If Datasht.Range("E" & i).Value < -0.1 Or Datasht.Range("E" & i).Value > 0.1 Then 'If greater than or less than
Datasht.Range("E" & i).Interior.ColorIndex = 6 'Change the color of affected cells if you need that
wsData.Range(wsData.Cells(RowNum, 1), wsData.Cells(RowNum, 4)).Value = _
Datasht.Range(Datasht.Cells(i, 2), Datasht.Cells(i, 5)).Value 'straight copy the values from the cells as it loops rather than using copy/paste
wsData.Range(wsData.Cells(RowNum, 2), wsData.Cells(RowNum, 4)).NumberFormat = "0.00%" 'change the number format of outputted cells to percentages (if needed)
RowNum = RowNum + 1 'move to the next row in the output
End If
Continue:
Resume Nexti
Nexti:
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
EDIT:
For the date to add a year my version would be just adding to what I gave earlier. Instead we now add an AND function to contain the OR, then checking if the YEAR in the cell is the current year. If you're only wanting this year then we can also forgo the IF statement which was checking that if the current month was January it would incorporate December. But if thats not needed then:
=AND(OR(MONTH(NOW())=MONTH(M8),MONTH(NOW())-1=MONTH(M8)),YEAR(M8)=YEAR(NOW()))
Or
=AND(MONTH(M8)>=MONTH(NOW())-1,MONTH(M8)<MONTH(NOW())+1,YEAR(M8)=YEAR(NOW()))
Both the same length and do the same thing just in different way.
I have one Excel sheet with 6000 rows. I need to delete entire rows if distinct values are less than, say, three in one particular column.
Per below example:
In column-A with the list of colours and in column-B with names.
If I filter any 'name in column-B and in column-A, if less than three distinct values = true then entire row should be deleted.
Rows with name- Chary should be deleted.
A B
Color Employee
Red Dev
blue Dev
blue Dev
Red Dev
black Dev
Red Dev
Red Chary
blue Chary
blue Chary
Red Chary
Red Chary
Red Chary
With my code:
First I filter name in column-B then paste the filtered data new workbook and there I will remove duplicates from column-A then will get the unique count.
If the unique count is less than 3 then activate the main sheet and will delete filtered rows and loop to next name.
Sub Del_lessthan_5folois()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
t = Now()
Set wb = ActiveWorkbook
Sheets("VALID ARNS").Activate
iCol = 2 '### criteria column
Set ws = Sheets("VALID ARNS")
Sheets("VALID ARNS").Activate
Set rnglast = Columns(iCol).Find("*", Cells(1, iCol), , , xlByColumns, xlPrevious)
ws.Columns(iCol).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUnique = Range(Cells(2, iCol), rnglast).SpecialCells(xlCellTypeVisible)
Workbooks.Add
Set newb = ActiveWorkbook
For Each strItem In rngUnique
If strItem <> "" Then
ws.UsedRange.AutoFilter Field:=iCol, Criteria1:=strItem.Value
newb.Activate
ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A1]
Application.CutCopyMode = False
Cells.EntireColumn.AutoFit
Dim uniq As Range
Set uniq = Range("A1:S" & Range("A" & Rows.Count).End(xlUp).Row)
uniq.RemoveDuplicates Columns:=7, Header:=xlYes
LastRow = ActiveSheet.UsedRange.Rows.Count
Cells.Delete Shift:=xlUp
Range("A1").Select
wb.Activate
If LastRow < "3" Then
ActiveSheet.AutoFilter.Range.Offset(1,0).Rows.SpecialCells(xlCellTypeVisible).Delete (xlShiftUp)
End If
End If
Next
ws.ShowAllData
MsgBox "The entire process took! " & Format(Now() - t, "hh:mm:ss") & " Minutes"
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
My code works in step by step debug mode but when run it skips a lot of rows.
Can this be related to more than 6000 rows?
How do I get the count of distinct values in Column-A when filtered in Column-B?
It's not exactly the same code that you posted as I had some troubles with it, but here's an alternative solution. I simply copy the data into another sheet (please add sheet called "Results" before you run my code), add two more columns with formulas (these will check if a given "Employee" should be deleted), filter on "TRUE" and then delete relevant rows.
From what I tested such solution seems to be faster than applying Advanced Filters, checking for unique values and then looping through the whole dataset. I hope it will work fine for your setup.
Here's the code:
Sub DeleteRows()
Dim t As Variant
Dim iCol As Long, lngLastRow As Long
Dim wsOrig As Worksheet, wsNew As Worksheet
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
t = Now()
Set wsOrig = Sheets("VALID ARNS")
Set wsNew = Sheets("Results")
iCol = 2 '### criteria column
With wsOrig
lngLastRow = .Columns(iCol).Find("*", Cells(1, iCol), , , xlByColumns, xlPrevious).Row
'copy into Results sheet
.Range("A1:B" & lngLastRow).Copy wsNew.Range("A1")
With wsNew
'add formulas
.Range("C1:D1").Value = VBA.Array("Instance", "Delete?")
.Range("C2:C" & lngLastRow).Formula = "=COUNTIFS($A$2:A2,A2,$B$2:B2,B2)"
.Range("D2:D" & lngLastRow).Formula = "=SUMIFS($C$2:$C$" & lngLastRow & ",$B$2:$B$" & lngLastRow & ",B2,$C$2:$C$" & lngLastRow & ",1)<3"
'delete when column D = TRUE
.Range("A1:D" & lngLastRow).AutoFilter Field:=4, Criteria1:="TRUE"
.Range("D2:D" & lngLastRow).SpecialCells(xlCellTypeVisible).Rows.Delete
'clear
.Range("A1:B" & lngLastRow).AutoFilter
.Range("C:D").Clear
End With
End With
MsgBox "The entire process took! " & Format(Now() - t, "hh:mm:ss") & " Minutes"
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
"VALID ARNS" sheet:
"Results" sheet (after running the code):
Edit:
Another option, using Scripting.Dictionary functionality:
Public Function getUnique(ByVal rngVals As Excel.Range) As Variant()
Dim objDictionary As Object
Dim rngRow As Excel.Range
Dim rngCell As Excel.Range
Dim strKey As String
Set objDictionary = CreateObject("Scripting.Dictionary")
For Each rngRow In rngVals.Rows
For Each rngCell In rngRow.Cells
strKey = strKey & "||" & rngCell.Text
Next rngCell
With objDictionary
If Not .Exists(Key:=Mid$(strKey, 3)) Then
Call .Add(Key:=Mid$(strKey, 3), Item:=Mid$(strKey, 3))
End If
End With
strKey = ""
Next rngRow
getUnique = objDictionary.Keys
Set rngVals = Nothing
Set rngRow = Nothing
Set rngCell = Nothing
End Function
Public Sub CountUnique()
Dim rngVals As Excel.Range
Dim varUnique() As Variant
Dim rngCell As Excel.Range
Dim varTemp As Variant
Set rngVals = Sheet3.Range("A2:B13").SpecialCells(12)
varUnique = getUnique(rngVals)
For Each rngCell In rngVals.Columns(2).Cells
varTemp = Filter(varUnique, rngCell.Text, True)
Debug.Print rngCell.Text, UBound(varTemp) - LBound(varTemp) + 1
Erase varTemp
Next rngCell
Set rngVals = Nothing
Set rngCell = Nothing
Erase varUnique
End Sub
I'm trying to fix the code to copy all rows based on unique values in a column to new worksheets
1. The table has a header in the range A1:CM4 that also includes a small picture
2. The last row contains a SUM formulas for each column C:CM
Trying to get:
1. Create new worksheets for each unique values in a column A (copy all appropriate rows, some cells are empty) including the header (A1:CM4) with the picture
3. Name new worksheets based on unique values (can be long names with spaces and commas: "aaaaa and bbbb, cccc")
4. The last row should contain SUM formulas and formatting for each column C:CM
I have a code that does part of the job (creates new sheets with unique values), but still struggling to fix next issues:
1. Doesn't copy all header (now copies only 1st row out of 4)
2. Doesn't keep/copy the last row with SUM formulas
3. Doesn't name a worksheet if the unique value is like: "aaaaa and bbbb, cccc" (less important)
Sub unique_data()
Dim RCount As Long
Dim Sht As Worksheet
Dim NSht As Worksheet
Dim I As Long
Dim TRrow As Integer
Dim Col As New Collection
Dim Title As String
Dim SUpdate As Boolean
Set Sht = ActiveSheet
On Error Resume Next
RCount = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row - 1
Title = "A1"
TRrow = Sht.Range(Title).Cells(1).Row
For I = 5 To RCount
Call Col.Add(Sht.Cells(I, 1).Text, Sht.Cells(I, 1).Text)
Next
SUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 1 To Col.Count
Call Sht.Range(Title).AutoFilter(1, CStr(Col.Item(I)))
Set NSht = Nothing
Set NSht = Worksheets(CStr(Col.Item(I)))
If NSht Is Nothing Then
Set NSht = Worksheets.Add(, Sheets(Sheets.Count))
NSht.Name = CStr(Col.Item(I))
Else
NSht.Move , Sheets(Sheets.Count)
End If
Sht.Range("A" & TRrow & ":A" & RCount).EntireRow.Copy NSht.Range("A1")
NSht.Columns.AutoFit
Next
Sht.AutoFilterMode = False
Sht.Activate
Application.ScreenUpdating = SUpdate
MsgBox "All done!", vbExclamation
End Sub
Would be very grateful for any help!
I managed to fix my code and get the correct results (still have some issues with naming spreadsheets as some names are rather long and excel does not take them to name the tabs), but anyways here is what the code is doing:
1. Creates new spreadsheets and copies appropriate rows based on unique values in a certain range (A5:..) of the main sheet
2. Renames new spreadsheets based on unique values
3. Copies all header's rows (4) to new spreadsheets
4. Copies the last row with SUM formulas and adjust the sum range for each spreadsheets based on the number of returned records
5. Formats new spreadsheets
I hope someone can use this code to solve similar puzzles or maybe make it more efficient.
Sub unique_data()
Dim RCount As Long
Dim Sht As Worksheet
Dim NSht As Worksheet
Dim I As Long
Dim Col As New Collection
Dim SUpdate As Boolean
Dim Lrow As Long
Dim NShtLR As Long
Set Sht = ActiveSheet
On Error Resume Next
RCount = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row - 1
Lrow = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row
For I = 5 To RCount
Call Col.Add(Sht.Cells(I, 1).Text, Sht.Cells(I, 1).Text)
Next
SUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 1 To Col.Count
Call Sht.Range("A5").AutoFilter(1, CStr(Col.Item(I)))
Set NSht = Nothing
Set NSht = Worksheets(CStr(Col.Item(I)))
If NSht Is Nothing Then
Set NSht = Worksheets.Add(, Sheets(Sheets.Count))
NSht.Name = CStr(Col.Item(I))
Else
NSht.Move , Sheets(Sheets.Count)
End If
Sht.Range("A5:A" & RCount).EntireRow.Copy NSht.Range("A5")
Next
Sheets.FillAcrossSheets Sht.Range("1:4")
For Each NSht In Worksheets
If Not NSht.Name = "MainReport" Then
NSht.Select
NShtLR = NSht.Cells(Sht.Rows.Count, 1).End(xlUp).Row + 1
Sht.Range("A" & Lrow).EntireRow.Copy NSht.Range("A" & NShtLR)
NSht.Range("C" & NShtLR).Formula = "=SUM(C5:C" & NShtLR - 1 & ")"
Range("C" & NShtLR).Copy Range("C" & NShtLR & ":CM" & NShtLR)
Rows("4:4").RowHeight = 230
Columns("A:A").ColumnWidth = 28
Columns("B:B").ColumnWidth = 29
Columns("C:C").ColumnWidth = 3
Columns("D:CB").ColumnWidth = 3.5
Columns("CC:CM").ColumnWidth = 4
NSht.Shapes.Range(Array("Picture 1")).Select
Selection.ShapeRange.IncrementLeft -3.6
Selection.ShapeRange.IncrementTop 47.4
Rows.EntireRow.Hidden = False
ActiveWindow.Zoom = 70
End If
Next
Sht.AutoFilterMode = False
Sht.Activate
Application.ScreenUpdating = SUpdate
MsgBox "All done!", vbExclamation
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.