I have a table of hours against weeks (start of the week is a Sunday). The weekly data goes up to 12-16 months dependent on user input. I want to create a VBA macro which will iterate through this table of weekly hours data and convert the columns into monthly data.
Example: All October 2021 related columns will collapse into 1 column called Oct-21. This will also combine the hours. 2nd row in the image below would equal 4 3 4 0= therefore value would be 11 in the new combined column's 2nd row.
My current thinking was calculating the Sundays between the start date and the last date which is below:
Dim d As Date, format As String, w As Long, FirstSunday As String
format = format(lastMonth, "Medium Date")
d = DateSerial(Year(format), Month(format), 1)
w = Weekday(d, vbSunday)
FirstSunday = d IIf(w <> 1, 8 - w, 0)
Any ideas on how to do this?
CodePudding user response：
Not sure how you want to group the weeks into months as some months will have 5 weeks. This code inserts a column when the month changes and then fills it with a sum formula for the relevant week columns. It assumes the dates are on row 1 , the task numbers in column 1 and the first week is in column 2.
Option Explicit
Sub ByMonth()
Dim wb As Workbook, ws As Worksheet
Dim LastCol As Long, LastRow As Long, c As Long, n As Long
Dim dt As Date
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
LastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
' scan cols from right to left insert new columns
Application.ScreenUpdating = False
For c = LastCol 1 To 3 Step -1
' add columns on month change
If Month(ws.Cells(1, c)) <> Month(ws.Cells(1, c - 1)) Then
ws.Columns(c).Insert
With ws.Columns(c)
.HorizontalAlignment = xlCenter
'.Interior.Color = RGB(255, 255, 200)
.Font.Bold = True
.Cells(1).NumberFormat = "@"
End With
End If
Next
' scan left to right filling new cols with sum() formula
' hide weekly columns
LastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
n = 0
For c = 2 To LastCol 1
If ws.Cells(1, c) = "" Then
dt = ws.Cells(1, c - 1)
ws.Cells(1, c) = MonthName(Month(dt), True) & " " & Year(dt)
ws.Cells(2, c).Resize(LastRow - 1).FormulaR1C1 = "=SUM(RC[-" & n & "]:RC[-1])"
n = 0
Else
ws.Columns(c).EntireColumn.Hidden = True
n = n 1
End If
Next
' copy visible month columns to sheet2
ws.Cells.SpecialCells(xlCellTypeVisible).Copy
With wb.Sheets("Sheet2")
.Activate
.Range("A1").PasteSpecial xlPasteValues
.Range("A1").Select
End With
' end
ws.Columns.Hidden = False
Application.ScreenUpdating = True
Application.CutCopyMode = False
MsgBox "Done"
End Sub
CodePudding user response：
Please, try the next code. It assumes that in column A:A, starting from the 6th row, there are (not sorted) tasks. If they are sorted, the code will run without problem, too. It uses arrays and a dictionary and mostly working in memory, should be very fast for big ranges:
Sub SumWeeksMonths()
Dim sh As Worksheet, sh1 As Worksheet, lastR As Long, arrWk, arrMonths, arrTasks
Dim i As Long, k As Long, j As Long, El, arr, arrFin, dict As New Scripting.Dictionary
Set sh = ActiveSheet 'use there the sheet to be processed
Set sh1 = sh.Next 'use here the sheet where the processed result to be returned
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row (in column A:A)
arrWk = sh.Range(sh.Range("B5"), sh.cells(5, sh.Columns.count).End(xlToLeft)).Value 'place the Week headers in a 2D array
ReDim arrMonths(UBound(arrWk, 2) - 1)'redim the 1D array to keep the unique munths, at a maximum size
For i = 1 To UBound(arrWk, 2) - 1 'create the array of (only) months:
If month(DateValue(arrWk(1, i))) <> month(DateValue(arrWk(1, i 1))) Then
k = k 1: arrMonths(k) = Format(DateValue(arrWk(1, i 1)), "mmm-yyyy")
Else
arrMonths(k) = Format(DateValue(arrWk(1, i)), "mmm-yyyy")
End If
Next i
ReDim Preserve arrMonths(k) 'preserve only the existing Date elements
For Each El In sh.Range("A4:A" & lastR).Value
dict(El) = 1 'extract the unique tasks (only to count them for ReDim the necessary array)
Next El
'place all the range to be processed in an array (for faster iteration):
arr = sh.Range("A5", sh.cells(lastR, sh.cells(5, sh.Columns.count).End(xlToLeft).Column)).Value
ReDim arrFin(1 To UBound(dict.Keys) 1, 1 To UBound(arrMonths) 2) 'reDim the final array to keep processed data
ReDim arrTasks(UBound(arrMonths)) 'redim the array to temporarily keep the array of each task summ
dict.RemoveAll: k = 0 'clear the dictionary and reitinialize the K variable
For i = 2 To UBound(arr) 'iterate between the main array elements:
If Not dict.Exists(arr(i, 1)) Then 'if the Task key does not exist:
For Each El In arrMonths 'iterate between each month in arrMonths:
For j = 2 To UBound(arr, 2) 'iterate between all arr columns for the i row:
If month(DateValue(arr(1, j))) = month(El) Then 'if column months is a specific arrMonths column:
arrTasks(k) = arrTasks(k) arr(i, j) 'sumarize everything in the arrTask each element
End If
Next j
k = k 1 'increment k, for the next month
Next El
dict.Add arr(i, 1), arrTasks 'create the dictionary key with the tasks array as item
ReDim arrTasks(UBound(arrMonths)): k = 0 'reinitialize arrTasks and k variable
Else 'if dictionary (task) key exists:
For Each El In arrMonths
For j = 2 To UBound(arr, 2)
If month(DateValue(arr(1, j))) = month(El) Then
arrTasks(k) = dict(arr(i, 1))(k) arr(i, j) 'add the sum to the allready existing elements
End If
Next j
k = k 1
Next El
dict(arr(i, 1)) = arrTasks 'make the item the updaded array
ReDim arrTasks(UBound(arrMonths)): k = 0 'reinitialize arrTasks and k variable
End If
Next i
'place the processed values in final array (arrFin):
For i = 0 To UBound(arrMonths) 'firstly the headers:
arrFin(1, i 2) = arrMonths(i)
Next i
'Extract the tasks value for each month and place in the final array appropriate columns:
For i = 0 To dict.count - 1 'iterate between the dictionary elements:
arrFin(i 2, 1) = dict.Keys(i) 'place the task in the array first column, starting from the second row
For j = 0 To UBound(dict.items(i)) 'iterate between the dictionary item array elements
arrFin(i 2, j 2) = dict.items(i)(j) 'place the appropriate array elements in the final array (arrFin)
Next j
Next i
'drop the final array at once and make some formatting:
With sh1.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2))
.Value = arrFin
With .rows(1)
.Font.Bold = True
.Interior.ColorIndex = 20
.BorderAround 1
End With
.EntireColumn.AutoFit
.BorderAround 1
End With
sh1.Activate 'to see the processing result...
MsgBox "Ready..."
End Sub
Please, test it and send some feedback.