mikemcbain
Board Regular
- Joined
- Nov 14, 2005
- Messages
- 152
- Office Version
- 365
- Platform
- Windows
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
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