Insert row based upon week number using VBA-CodePudding

I'll admit to not being the best at VBA.

I have an excel sheet which has some code behind a button to do an import from a network location.

Column B has a date in the format dd/mm/yyyy.

My import removes duplicates and re orders chronologically, I would like to also add some visual method of dividing the rows into weeks based on week numbers. I was thinking of inserting a row.

How should I test for the week number changing from week 45 to 46 for instance to add a row?

CodePudding user response：

Group Data By Weeks

Note that the Week column has nothing to do with the code, only the Date column is considered.

Usage

Sub GroupWeekTEST()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
    
    GroupByWeek ws, "B2", "A", "Week " ' you can omit the last two defaults

End Sub

The Method

Sub GroupByWeek( _
        ByVal ws As Worksheet, _
        ByVal WeekFirstCellAddress As String, _
        Optional ByVal GroupColumn As Variant = "A", _
        Optional ByVal GroupBaseName As String = "Week ")
    
    ' Reference the single-column range ('crg').
    
    Dim fCell As Range: Set fCell = ws.Range(WeekFirstCellAddress)
    
    Dim lCell As Range
    Set lCell = fCell.Resize(ws.Rows.Count - fCell.Row   1) _
        .Find("*", , xlFormulas, , , xlPrevious)
    If lCell Is Nothing Then Exit Sub ' no data in column range
    
    Dim rCount As Long: rCount = lCell.Row - fCell.Row   1
    Dim crg As Range: Set crg = fCell.Resize(rCount)
    
    ' Write the values from the range to an array ('Data').
    
    Dim Data As Variant
    If rCount = 1 Then
        ReDim Data(1 To 1, 1 To 1): Data = crg.Value
    Else
        Data = crg.Value
    End If
    ' The 1st column will hold the cells (range objects).
    ' Add a 2nd column to hold the week numbers.
    ReDim Preserve Data(1 To rCount, 1 To 2)
    
    ' Write the cells and week numbers to the top of the array.
    
    Dim CurrValue As Variant
    Dim CurrDate As Date
    Dim OldWeek As Long
    Dim NewWeek As Long
    Dim sr As Long
    Dim dr As Long
    
    For sr = 1 To rCount
        CurrValue = Data(sr, 1)
        If IsDate(CurrValue) Then
            NewWeek = Application.WeekNum(CurrValue)
            If NewWeek <> OldWeek Then
                dr = dr   1
                Set Data(dr, 1) = crg.Cells(sr)
                Data(dr, 2) = NewWeek
                OldWeek = NewWeek
            End If
        End If
    Next sr
    If dr = 0 Then Exit Sub ' no dates found
                
    ' Write the group titles to the specified column of the newly inserted rows.
                
    Application.ScreenUpdating = False
                
    For dr = dr To 1 Step -1
        With Data(dr, 1)
            .EntireRow.Insert xlShiftDown
            .Offset(-1).EntireRow.Columns(GroupColumn).Value _
                = GroupBaseName & Data(dr, 2)
        End With
    Next dr
                
    Application.ScreenUpdating = True
    
    ' Inform.
    
    MsgBox "Week grouping added.", vbInformation
                
End Sub