VBA finding column header and autofill contents by creating dynamic range

[afkzaman]

End Sub

Hi all, I'm trying to write a macro where i need to find the column header 'dec-26' in row 4 and extend the date till 'dec-31', i.e. add another 60 months and autofill the newly created cells so that the contents/formulas remain intact. I wrote a small part of macro using 'record macro' which serves as the basic but far from what i want.

Sub Testmacro()
Dim ws As Worksheet
Dim lcol As Long, lrow As Long

'set the relevant worksheet
    Set ws = Workbooks("sample.xlsx").Sheets("data")

'find the date cell in row 4
    Cells.Find(What:="dec-26", After:=ActiveCell, LookIn:=xlValues, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
     
'expand date till dec-31 (need to insert new columns as there's only one blank column after G4)

        Selection.AutoFill Destination:=Range("G4:BO4"), Type:=xlFillDefault

'autofill all the contents/formulas to the newly created cells
        Range("G5:G31").Select
        Selection.AutoFill Destination:=Range("G5:BO31"), Type:=xlFillDefault
   
End Sub

What I'm trying to do:

1. Auto-increment column headers till 'dec-31' after finding the header 'dec-26', but not by hard coding range "G4:BO4". From cell I4 the series 'Jan-17 to Dec-26' starts again for another 12 times under different main headings with one blank column between them. When I run my macro it does not insert any new columns.

2. Autofill the contents in the newly created cells by using dynamic range, not by hard-coded range. Row 5 to 30 need to be copied in the new cells.

I'm learning and trying to figure out the macro myself but It's bit difficult for a beginner. Any sort of help will be highly appreciated. Thanks in advance

 

[Fluff]

Hi & welcome to MrExcel
Not quite sure if I have understood you correctly, but this will insert new columns after Dec-26 & will then auto fill all the rows in the new columns with the data in the Dec-26 column

Sub Testmacro()
    Dim ws As Worksheet
    Dim lcol As Long, lrow As Long

'set the relevant worksheet
    Set ws = Sheets("data")
    lrow = ws.Cells.Find("*", After:=ws.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'find the date cell in row 4
    lcol = ws.Rows(4).Find(What:="Dec-26", LookIn:=xlValues, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Column
     
'expand date till dec-31 (need to insert new columns as there's only one blank column after G4)
    ws.Columns(lcol + 1).Resize(, 60).Insert

'autofill all the contents/formulas to the newly created cells
    ws.Cells(4, lcol).Resize(lrow - 3).AutoFill Destination:=ws.Cells(4, lcol).Resize(lrow - 3, 61), Type:=xlFillDefault
   
End Sub

 

[afkzaman]

Hi Fluff, thank you very much, hope MrExcel would be a great resouce for me for learning new excel/vba skills.

Your codes worked perfectly, thank you. But for the other part of the problem (sorry i couldn't convey my message properly), the ws has multiple 'dec-12' in row 4, it's a series of months starting from Jan-17 to Dec-26 which appear multiple times with one blank column between each series. so, i have to find all 'dec-26' cells in row 4 and then apply your codes. I used findnext function and modified your codes to below:

Sub Testmacro()
    Dim ws As Worksheet
    Dim aCell As Range, bCell As Range, lrow As Long
    Dim foundAt As String
    
'set the relevant worksheet
    Set ws = Sheets("data")
    lrow = ws.Cells.Find("*", after:=ws.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'find the first date cell in row 4
     Set aCell = ws.Rows(4).Find(What:="Dec-26", LookIn:=xlValues, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
        
  If Not aCell Is Nothing Then
    Set bCell = aCell
    foundAt = aCell.Address
  
  Do
    Set aCell = ws.Rows(4).FindNext(after:=aCell)
        
        If Not aCell Is Nothing Then
         If aCell.Address = bCell.Address Then Exit Do
            foundAt = foundAt & ", " & aCell.Address
        Else
         Exit Do
        End If
     Loop
    End If

Now, 'foundAt' has multiple comma separated cells containing 'dec-26'. When i try to convert it to a range object and apply your codes, it fails to compile as i'm not doing it correctly. Could you please tell me if my above modifications are correct and what to do next? These are the remaining codes:

'expand date till dec-31
    ws.Columns(foundAt + 1).Resize(, 60).Insert

'autofill all the contents/formulas to the newly created cells
    ws.Cells(4, foundAt).Resize(lrow - 3).AutoFill Destination:=ws.Cells(4, foundAt).Resize(lrow - 3, 61), Type:=xlFillDefault
   
End Sub

Thank you again for your help.

 

[afkzaman]

the ws has multiple 'dec-12' in row 4

Sorry, it should be 'dec-26', not 'dec-12'

 

[Fluff]

OK, how about

Sub Testmacro()

    Dim ws As Worksheet
    Dim lcol As Long
    Dim lrow As Long
    Dim Ans As Long
    Dim Cnt As Long
    Dim acell As Range
    
'set the relevant worksheet
    Set ws = Sheets("data")
    lrow = ws.Cells.Find("*", after:=ws.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'find the date cell in row 4
    Ans = WorksheetFunction.CountIf(ws.Rows(4), "12/01/2026")
    Set acell = ws.Range("A4")
    If Ans >= 1 Then
        For Cnt = 1 To Ans
            Set acell = ws.Rows(4).Find(What:="Dec-26", after:=acell, LookIn:=xlValues, LookAt _
                :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                False, SearchFormat:=False)
            lcol = acell.Column
    
                ws.Columns(lcol + 1).Resize(, 60).Insert
    
                ws.Cells(4, lcol).Resize(lrow - 3).AutoFill Destination:=ws.Cells(4, lcol).Resize(lrow - 3, 61), Type:=xlFillDefault
        Next Cnt
    End If
End Sub

 

[afkzaman]

@Fluff,

The codes work perfectly. Now I'll go through each line of the codes to learn more about it. And thank your very much for your support.

Regards, Zaman

 

[Fluff]

Glad to help & thanks for the feedback

 

[Biz]

Code is good except I think we can make ws statements redundant is With statement.

My revised code using Fluff logic.

Dim aStartTime
Dim strFullName As String
Dim ProcName As String
Dim bErrorHandle As Boolean
Dim wsSource As Worksheet, wsDestination As Worksheet
Dim rowsAffected As Long, iDelete As Long
Const DblSpace As String = vbNewLine & vbNewLine
Const CoName As String = "Job Done"

Sub Testmacro()
    Dim ws As Worksheet
    Dim lcol As Long
    Dim lrow As Long
    Dim Ans As Long
    Dim Cnt As Long
    Dim acell As Range
    
    On Error GoTo errHandler
    bErrorHandle = False
    
    '~~> Start Timer
    aStartTime = Now()
    
    '~~> Speeding Up VBA Code
    Call SpeedUp(False)
    
    
    'set the relevant worksheet
    Set ws = Sheets("data")
    
    With ws
        lrow = .Cells.Find("*", after:=.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        'find the date cell in row 4
        Ans = WorksheetFunction.CountIf(.Rows(4), "12/01/2026")
        Set acell = .Range("A4")
        If Ans >= 1 Then
            For Cnt = 1 To Ans
                Set acell = .Rows(4).Find(What:="Dec-26", after:=acell, LookIn:=xlValues, LookAt _
                    :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                    False, SearchFormat:=False)
                lcol = acell.Column
                
                .Columns(lcol + 1).Resize(, 60).Insert
                
                .Cells(4, lcol).Resize(lrow - 3).AutoFill Destination:=.Cells(4, lcol).Resize(lrow - 3, 61), Type:=xlFillDefault
            Next Cnt
        End If
      End With
BeforeExit:
        '~~> Remove items from memory
        Set ws = Nothing
        
        '~~> Speeding Up VBA Code
        Call SpeedUp(True)
        
        If bErrorHandle = False Then
            MsgBox "Time taken: " & Format(Now() - aStartTime, "h:mm:ss") & _
                DblSpace & " You're good to go!" & DblSpace & _
                CoName & Chr(32) & Chr(169) & Chr(32) & Year(Date), vbInformation, "Excellent"
        End If
        
        Exit Sub
errHandler:
        '~~> Error Occurred
        bErrorHandle = True
        ProcName = Application.VBE.ActiveCodePane.CodeModule.ProcOfLine(Application.VBE.ActiveCodePane.TopLine, 0)
        MsgBox "Procedure: - " & ProcName & DblSpace & Err.Description, vbCritical, "Oops I did it again...."
        Resume BeforeExit
        
        
    End Sub
    
    Public Function SpeedUp(Optional bSpeed As Boolean = True)
    With Application
        .ScreenUpdating = bSpeed 'Prevent screen flickering
        .Calculation = IIf(bSpeed, xlAutomatic, xlCalculationManual) 'Preventing calculation
        .DisplayAlerts = bSpeed 'Turn OFF alerts
        .EnableEvents = bSpeed 'Prevent All Events
        '.Cursor = IIf(bSpeed, xlDefault, xlWait) 'Prevent Hour Glass
        '.StatusBar = IIf(bSpeed, vbNullString, "Please wait...")
    End With
End Function

 

[afkzaman]

Hi Biz,

It looks like a lot of new codes, I will look through and run it once i'm back to my desk again. Regards.

 

[afkzaman]

@Fluff

ws.Cells(4, lcol).Resize(lrow - 3).AutoFill Destination:=ws.Cells(4, lcol).Resize(lrow - 3, 61), Type:=xlFillDefault

When you got some time, could you please explain why we are using lrow-3 instead of lrow here? I understood other codes but can't understand this logic. Thank you. Regards.