VBA to copy information down but on a loop - vba

Question

I tried to run this in a macro but somehow the loop didn’t work as it kept referencing the cells when I need this to just run down until it hits the end. I am looking to do the following:
If there is a value in column D and nothing in column B then the information need to be copied down. To copy it will look for column A to match but look for the top line of the match so there is values in column B. once it finds the top row the code should copy down rows B,E & H
the code i used is a recorded macro. this look for a value in B goes to the bottom (using Ctrl + Down) copies this value and uses Ctrl + Shift + down, the up one to find the end. pastes the value then moves across to the other columns. but i can only get this to run on the first section it needs to repeat until the end. the end is defined on row 10000:
Sub Sort_The_Fus_To_One_Line_2()
Application.Goto Reference:="R8C2"
Range("B8").Select
Selection.End(xlDown).Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
Range("B10:B43").Select
ActiveSheet.Paste
Range("E10").Select
Application.CutCopyMode = False
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
Range("E10:E43").Select
ActiveSheet.Paste
Range("H10").Select
Application.CutCopyMode = False
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
Range("H10:H43").Select
ActiveSheet.Paste
Range("B10").Select
Selection.End(xlDown).Select
End Sub
Can someone help!? Thanks!

Answer 1

I think this is something like what you're after:
Sub Test()
Dim rStart As Range, rEnd As Range
Dim FirstAdd As String
Dim lLastRow As Long
lLastRow = 10001
With Worksheets("Sheet1").Columns(2)
'Find the first non-blank cell in column B.
Set rStart = .Find(What:="*", _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchDirection:=xlNext)
'rStart will be Nothing if the column is empty.
If Not rStart Is Nothing Then
FirstAdd = rStart.Address 'Very first found address.
Do
'Find the next non-blank cell in column B.
Set rEnd = .FindNext(rStart)
If rEnd.Row < rStart.Row And rStart.Row < lLastRow Then
'The cell reference is relative to the column in the With command.
'making column 1 = sheet column 2.
Set rEnd = .Cells(lLastRow, 1)
End If
'If the second address isn't the same as the very first address and
'the second address isn't the row below the start address then copy the value down.
If rEnd.Address <> FirstAdd And rStart.Offset(1).Address <> rEnd.Address Then
'Places the value from the Start row into every cell between one below the
'start row to one cell above the end row.
Worksheets("Sheet1").Range(rStart.Offset(1), rEnd.Offset(-1)) = rStart.Value
Worksheets("Sheet1").Range(rStart.Offset(1), rEnd.Offset(-1)).Offset(, 3) = rStart.Offset(, 3).Value
Worksheets("Sheet1").Range(rStart.Offset(1), rEnd.Offset(-1)).Offset(, 6) = rStart.Offset(, 6).Value
End If
'Set the new start address as the previous end address.
Set rStart = rEnd
Loop While rStart.Row < lLastRow
End If
End With
End Sub