1004 error .advancedfilter

[Youngdand]

Hi,

I have a sheet, with a dataset which is 18 columns, however, further datasets of 18 columns are repeated throughout the sheet horizontally. I need to stack this data vertically. below is a crude example of the table i have and what i need to do is take all the data outside of columns a and b, and to add them to bottom of column a and b ideally without any spaces.

A	B	C	D	E	F	G	H	I	J
Set 1	Set1	Set 2	Set 2	Set 3	Set 3	Set 4	Set 4	Set 5	Set 5
acb	acb	abc1	abc1
bcd	bcd	bcd1	bcd1	bcd2	bcd2
cde	cde	cde1	cde1
def	def	def1	def1	def2	def2	def3	def3
efg	efg	efg1	efg1
fgh	fgh	fgh1	fgh1	fgh2	fgh2	fgh3	fgh3	fgh4	fgh4
ghi	ghi	ghi1	ghi1
ghi	ghi

<tbody>
</tbody>

I have been trying to write a macro which achieves this however, i am getting a 1004 error in relation to an advanced filter i am trying to perform.

Sub Stackrepeats()
Dim lr As Long
Dim lastcol As Long
Dim cr As Range
Dim TS As Worksheet
Dim NLR As Long
Set TS = ActiveSheet

Do Until lastcol = 18
With TS.UsedRange
lr = Cells(Rows.Count, 1).End(xlUp).Row
lastcol = .Columns(.Columns.Count).Column
Set cr = .Range(.Cells(1, 19), .Cells(lr, lastcol))
cr.AdvancedFilter Action:=xlFilterCopy, criteriarange:=TS.Range(.Cells(1, 1)), copytorange:=TS.Range(.Cells(lr + 1, 1)), Unique:=True
cr.ClearContents
Application.CutCopyMode = False
End With
Loop
End Sub

it fails on line:

cr.AdvancedFilter Action:=xlFilterCopy, criteriarange:=TS.Range(.Cells(1, 1)), copytorange:=TS.Range(.Cells(lr + 1, 1)), Unique:=True

Can anyone help on this? is there a better way of achieving what i am after?

Cheers,

Dan.

 

[Dryver14]

Are you missing a criteria?

 

[Youngdand]

HI,

Not that i am aware of, as i thought using this method, i would get only unique values based on the rangecriteria specified.

But that just be my twisted logic!.

 

[Youngdand]

So it took a while with my basic knowledge of VBA but eventually i came up with the solution below, if anyone is interested:

Sub Stackrepeats()
Dim lr As Long
Dim lastcol As Long
Dim cr As Range
Dim TS As Worksheet
Dim NLR As Long
Set TS = ActiveSheet
TS.Range("a1").EntireRow.Insert
Application.ScreenUpdating = False
With TS.UsedRange
lr = TS.Cells(Rows.Count, 1).End(xlUp).Row
lastcol = .Columns(.Columns.Count).Column
Debug.Print (lastcol)
End With
For i = 18 To lastcol
If lastcol = 18 Then GoTo Finish
lr = TS.Cells(Rows.Count, 1).End(xlUp).Row
Set cr = TS.Range(Cells(1, 19), Cells(lr, lastcol))
If TS.AutoFilterMode = True Then TS.AutoFilterMode = False
With cr
.AutoFilter field:=1, Criteria1:="<>"
.SpecialCells(xlCellTypeVisible).Copy
End With
TS.AutoFilterMode = False
With TS
.Cells(lr + 1, 1).Select
.Paste
End With
cr.Delete xlShiftToLeft
lastcol = lastcol - 18
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True

Finish:
TS.UsedRange.Sort Key1:=Range("A1"), Order1:=xlAscending
Exit Sub
End Sub