Copy subtotal cell to rows below

[Philip041]

Hi,

I have some data which looks like below:

Name	Country	Code
Germany	Germany	DE
John	Germany
Nancy	Germany
Fred	Germany
Brian	Germany
France
Danny	France	FR
John	France
Nancy	France
Fred	France
Derrick	France

<tbody>
</tbody>

I want to try and find a way of copying the code to the cells below it. My logic is:

Scroll down Column C (Code)
Copy first non-empty cell
Paste to next empty cell
Repeat
When get to non-empty cell copy that cell and carry out above process

Is there a way to fix this?

The data is about 30,000 rows long and my problem field is in Column H.

Any help much appreciated!

 

[MrTeeny]

Try something like this, I've used column A to set the last row but obviously change that to whatever column your name data is in. In the sample you posted what you asked for will post DE against France in the name column. So if your data is as above you might need to take that into account

Sub fillCells()
On Error GoTo xit:
Application.ScreenUpdating = False
Application.Calculation = xlCalculateManual
Dim FinalRow As Integer
  
  FinalRow = Cells(Rows.Count, "A").End(xlUp).Row




    For i = 2 To FinalRow
     
    If Range("H" & i).Value = "" Then Range("H" & i).Value = Range("H" & i - 1).Value




    Next i
  


xit:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


End Sub

 

[Fluff]

Alternatively if you use this

    If Range("H" & i).Value = "" And Range("H" & i + 1) = "" Then
        Range("H" & i).Value = Range("H" & i - 1).Value
    End If

the row where you have France in col A will not get filled in

 

[SyedUsman]

Paste in cell D2 assuming data is in Cell A1:C30000 INCLUDING HEADERS & COPY DOWN

=IF(C2="",D1,C2)

 

[Philip041]

Brilliant - I used the code and it worked a charm, thanks!