Make my Macro Loop

[mikemcbain]

G'day Magicians
Should be simple for you to help me today?
The macro I recorded below called xtract, works perfectly however I need it to loop several thousand times or until it finds that the cell in Column A is blank.
With thanks in great anticipation...
Old Mike.

Sub xtract()
'
' xtract Macro
'
' Keyboard Shortcut: Ctrl+x
'
Sheets("Results").Select
Application.Goto Reference:="R1C1"
Selection.End(xlToRight).Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, -1).Range("A1").Select
Selection.Copy
Sheets("BTDBASE").Select
Application.Goto Reference:="R2C5"
ActiveSheet.Paste
Application.CutCopyMode = False
Application.CutCopyMode = False
Application.CutCopyMode = False
ActiveCell.Offset(5, -4).Range("A1:AD99993").AdvancedFilter Action:= _
xlFilterCopy, CriteriaRange:=ActiveCell.Offset(-1, -4).Range("A1:AD2"), _
CopyToRange:=ActiveCell.Offset(5, 30).Range("A1:AD1"), Unique:=False
ActiveWindow.ScrollColumn = 2
ActiveCell.Offset(2, 26).Range("A1:D1").Select
Selection.Copy
Sheets("Results").Select
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.Goto Reference:="R1C1"
Selection.End(xlToRight).Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, -1).Range("A1").Select
Selection.Copy
Sheets("BTDBASE").Select
Application.Goto Reference:="R2C5"
ActiveSheet.Paste
Application.CutCopyMode = False
Application.CutCopyMode = False
Application.CutCopyMode = False
ActiveCell.Offset(5, -4).Range("A1:AD99993").AdvancedFilter Action:= _
xlFilterCopy, CriteriaRange:=ActiveCell.Offset(-1, -4).Range("A1:AD2"), _
CopyToRange:=ActiveCell.Offset(5, 30).Range("A1:AD1"), Unique:=False
ActiveWindow.ScrollColumn = 2
ActiveCell.Offset(2, 26).Range("A1:D1").Select
Selection.Copy
Sheets("Results").Select
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub

 

[DanteAmor]

until it finds that the cell in Column A is blank

For all cells in column A, starting at cell A3

Try this:

Sub xtract()
  Dim c As Range
  Application.ScreenUpdating = False
  For Each c In Sheets("Results").Range("A3", Sheets("Results").Range("A" & Rows.Count).End(3))
    With Sheets("BTDBASE")
      .Range("E2").Value = c.Value
      .Range("A7:AD" & .Range("A" & Rows.Count).End(3).Row).AdvancedFilter 2, .Range("A1:AD2"), .Range("AI7:BL7")
      c.Offset(0, 1).Resize(1, 4).Value = .Range("AE4:AH4").Value
    End With
  Next c
End Sub

 

[mikemcbain]

For all cells in column A, starting at cell A3

Try this:

Sub xtract()
  Dim c As Range
  Application.ScreenUpdating = False
  For Each c In Sheets("Results").Range("A3", Sheets("Results").Range("A" & Rows.Count).End(3))
    With Sheets("BTDBASE")
      .Range("E2").Value = c.Value
      .Range("A7:AD" & .Range("A" & Rows.Count).End(3).Row).AdvancedFilter 2, .Range("A1:AD2"), .Range("AI7:BL7")
      c.Offset(0, 1).Resize(1, 4).Value = .Range("AE4:AH4").Value
    End With
  Next c
End Sub

G'day DanteAmor
Your solution is so unbelievably quick and clever I am almost in a state of stunned shock. Thank you.
If I wasn't nearly 84yo I would be asking you for lessons in VBA but my time is probably too short?
I do have a feeling that I can also use your code in a couple of other Databases that I utilise.
You are truly a Magician.
Old MIke.

 

[DanteAmor]

I'm glad to help you. I appreciate your kind comments.