VBA finding column header and autofill contents by creating dynamic range

afkzaman

New Member
Joined
Aug 22, 2017
Messages
18
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.
Code:
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
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
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
Code:
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
 
Upvote 0
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:
Code:
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:

Code:
'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.
 
Upvote 0
OK, how about
Code:
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
 
Upvote 0
@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
 
Upvote 0
Glad to help & thanks for the feedback
 
Upvote 0
Code is good except I think we can make ws statements redundant is With statement.

My revised code using Fluff logic.

Code:
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
 
Last edited:
Upvote 0
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.
 
Upvote 0
@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.
 
Upvote 0

Forum statistics

Threads
1,213,489
Messages
6,113,949
Members
448,534
Latest member
benefuexx

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top