code to auto fill down using Macro

[snuggles57]

Re: How to write code to auto fill down using Macro




I am hoping some one can help me I am looking for some code to FillDown a selection of non consecutive cells. I recorded a basic macro below.


This is only a small sample of number of rows that I need to fill down.
Range("A22:D25").Select
Selection.FillDown
The next range skips 2 rows then continues to the next range
Range("A28:D31").Select
Selection.FillDown
This needs to continue in the pattern until the final range or stop if any of the copy down cells is blank. Final range would be.
Range("A3436:D3439").Select
Selection.FillDown






The column to the left of the cells mention in the macros have detail of hours worked start time etc when filtering on any of the other columns the persons name does not appear. Thats why I need to fill down spanning the four rows.


Many thanks for any help given.

 

[JackDanIce]

Untested so advisable to test on a copy of your sheet, however, try:

Sub FillDown()

    Dim x   As Long
    Dim LR  As Long
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    LR = Cells(Rows.count, 1).End(xlUp).row
    
    For x = 22 To LR Step 6
        Cells(x, 1).Resize(4, 4).FillDown
    Next x
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

This assumes you always have 3 rows to fill down, then 2 blank rows, then 3 rows to fill down, then 2 blank rows, etc until the last row in column A is reached.

 

[snuggles57]

Thanks for replying this code performs the fill down as required but is there a way of stopping the action when it comes to a blank cell.

Untested so advisable to test on a copy of your sheet, however, try:

Sub FillDown()

    Dim x   As Long
    Dim LR  As Long
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    LR = Cells(Rows.count, 1).End(xlUp).row
    
    For x = 22 To LR Step 6
        Cells(x, 1).Resize(4, 4).FillDown
    Next x
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

This assumes you always have 3 rows to fill down, then 2 blank rows, then 3 rows to fill down, then 2 blank rows, etc until the last row in column A is reached.

 

[JackDanIce]

Try:

Sub FillDown()


    Dim x   As Long
    Dim LR  As Long
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    LR = Cells(Rows.count, 1).End(xlUp).row
    
    For x = 22 To LR Step 6
        If Len(Cells(x, 1).Value) > 0 Then Cells(x, 1).Resize(4, 4).FillDown
    Next x
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With


End Sub

It tests if cell Ax is empty, if not, it performs the fill.

 

[snuggles57]

Try:

Sub FillDown()


    Dim x   As Long
    Dim LR  As Long
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    LR = Cells(Rows.count, 1).End(xlUp).row
    
    For x = 22 To LR Step 6
        If Len(Cells(x, 1).Value) > 0 Then Cells(x, 1).Resize(4, 4).FillDown
    Next x
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With


End Sub

It tests if cell Ax is empty, if not, it performs the fill.

It seems to continue to run after reaching a blank cell the cell has some formatting cell is filled in green would this prevent it from stopping.

 

[JackDanIce]

It shouldn't do, but difficult to tell without being able to see your spreadsheet I'm afraid. Is the blank cell in column A? Is there anything else that can be tested?

 

[snuggles57]

Thankyou for your help it appears there was a problem with other Macros in the original workbook. I copied the data to a blank book and the above code worked a treat. It actually works out better as all the other format restrictions from the original workbook is not included in the new one. Thank you very much.

 

[JackDanIce]

You're welcome, glad it's resolved