Filtered range copy failure

[rjplante]

I have a table (shown below) and the macro (included below) and when I run it, I get the filters to apply correctly but I cannot get the filtered range to copy so that I can paste it into the next table. I get a Run-Time error '1004': Application -defined or object-defined error. It crashes on the following line: sh.AutoFilter.Range.Range("A" & ffr & ":A" & flr).Copy

I am trying to copy column A and paste into column A of the new worksheet. The I need to copy columns H:L for the filtered set of rows and paste that into Columns B:F of the new worksheet.

What do I need to fix it?

Sub Gantt_Group_Transfer()

Application.ScreenUpdating = False
Application.EnableEvents = False

Dim sh As Worksheet
Dim myCol As Long
Dim ffr As Long
Dim flr As Long
Dim lr As Long
Dim lr2 As Long
Dim myFilter As String
Dim lr3 As Long
  
  Set sh = ActiveSheet
  myCol = ActiveCell.Column
  lr = sh.Range("A" & Rows.Count).End(4).Row
  myFilter = sh.Range("B" & ActiveCell.Row).Value
  
  '   Clear out old data
    Sheets("Combo Gantt Chart").Range("AK1").ClearContents
    Sheets("Combo Gantt Chart").Range("A3:F103").ClearContents
    Sheets("Combo Gantt Chart").Range("AN1").ClearContents
    
'   Column Heading Transfer
    Sheets("Combo Gantt Chart").Range("AK1").Value = Sheets("Master Plan").Cells(1, myCol)
    Sheets("Combo Gantt Chart").Range("AN1").Value = myFilter
    Sheets("Master Plan").Cells(3, myCol).Select
    ActiveCell.End(xlDown).Select
  
  With Sheets("Combo Gantt Chart")
    'Data Transfer
    If sh.AutoFilterMode Then sh.AutoFilterMode = False
    If .AutoFilterMode Then .AutoFilterMode = False
    lr2 = .Range("A" & Rows.Count).End(3).Row + 1
    '
    sh.Range("A2", Cells(lr, myCol)).AutoFilter myCol, "<>"
    sh.Range("A2", Cells(lr, myCol)).AutoFilter field:=2, Criteria1:=myFilter, Operator:=xlFilterValues
    ffr = sh.Range("A2").End(xlDown).Row
    flr = sh.Range("A" & Rows.Count).End(4).Row
    
    sh.AutoFilter.Range.Range("A" & ffr & ":A" & flr).Copy
    .Range("A" & lr2).PasteSpecial xlPasteValues
    sh.AutoFilter.Range.Range(sh.Cells(4, myCol), sh.Cells(lr, myCol + 4)).Copy
    .Range("B" & lr2).PasteSpecial xlPasteValues
    sh.ShowAllData
    sh.AutoFilterMode = False
    .AutoFilterMode = False
  End With

    Application.CutCopyMode = False
    
    Sheets("Combo Gantt Chart").Activate


'   Sort the chart data from oldest to newest
    lr3 = sh.Range("A" & Rows.Count).End(3).Row + 1
    
    Range("A2:F" & lr3).Select
    ActiveWorkbook.Worksheets("Combo Gantt Chart").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Combo Gantt Chart").Sort.SortFields.Add2 Key:= _
        Range("B3:B" & lr3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Combo Gantt Chart").Sort
        .SetRange Range("A2:F" & lr3)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Sheets("Combo Gantt Chart").Range("A3").Select
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True


End Sub

Machine Follow-Up Test.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L
1	JOB #	Team	Company	Rev.	Reason for Rev	Receive PO and Down Payment (Project Start Date)	Kick off	Mechanical Design Output			Mechanical Design Output
2									Plan	Plan	Actual	Actual
4	111	3	AAA	A	Original Quote ABC-123	11-Mar-2020	16-Mar-2020	16-Mar-2020	15	6-Apr-2020	15	6-Apr-2020
5	222	3	BBB	A		20-Feb-2020	23-Mar-2020	23-Mar-2020	10	6-Apr-2020	10	6-Apr-2020
12	333	3	CCC	C	Updated Spec 4/1/2020	2-Nov-2018	10-Feb-2018	10-Feb-2018	20	9-Mar-2018	20	9-Mar-2018
14	444	3	DDD	E	Updated Mechanical 3/25/2020	7-Mar-2019	27-Mar-2019	27-Mar-2019	25	1-May-2019	25	1-May-2019
Master Plan

Cell Formulas
Range	Formula
J4:J5,J12,J14	J4	=IF(H4="","",WORKDAY(H4,I4,Data!$F$2:$F$113))
L4:L5,L12,L14	L4	=IF(H4="","",WORKDAY(H4,K4,Data!$F$2:$F$113))

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A1:H1,M1:P1,R1:V1,A2:S2,X2:Z2,AZ1:BC1,X1:AC1,A1048574:CX1048576,CY1048574,AE1:AI1,AE2:AF2,AK2,AK1:AN1,AP2,AP1:AS1,AU1:AV1,AU2,AZ2,BE1:BH1,BE2,BJ1:BN1,BJ2:BK2,BP2,BP1:BS1,BU2:BW2,BU1:BZ1,CB1:CE1,CB2,CG1:CK1,CG2:CH2,CM2,CR2:CT2,CM1:CP1,CR1:CW1,CY1:CY2	Expression	=COLUMN(A4)=SelCol	text	NO

Here is the blank worksheet template to transfer the copied data into.

Machine Follow-Up Test.xlsm
	A	B	C	D	E	F
1			Plan	Plan	Actual	Actual
2	JOB #	Start Date	# working days	End Date	# working days	End Date
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Combo Gantt Chart

Thanks for the help.

 

[Fluff]

Try

sh.AutoFilter.Range.Offset(1).Columns(1).Copy

 

[PritishS]

Hi,

Try this code after filtering Data. This will copy desired range and paste it in 'Combo' sheet. Modify sheet names in code as per your requirment.

Sub Copy_Data()

Dim rngDB As Range, rng As Range
Dim n As Integer
Set rngDB = ThisWorkbook.Worksheets("Sheet5").UsedRange.SpecialCells(xlCellTypeVisible) 'Chnage Sheet5 as per your First sheet name
n = rngDB.SpecialCells(xlCellTypeLastCell).Row

Sheets("Sheet5").Range("A3:A" & n).Copy
Sheets("Combo").Range("A3").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
Application.CutCopyMode = False

Sheets("Sheet5").Range("H3:L" & n).Copy
Sheets("Combo").Range("B3").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
Application.CutCopyMode = False

End Sub

 

[rjplante]

Fluff,

I got past the first block to copy and not it is crashing with the same error on this line:
sh.AutoFilter.Range.Range(sh.Cells(4, myCol), sh.Cells(lr, myCol + 4)).Copy

I tried change the line to resemble the first one so it reads: sh.AutoFilter.Range.Offset(1).Columns(myCol & ":" & (myCol + 4)).Copy, but I get the same result.

++++++++++++++++++++++++++++++

PritishS - I tried implementing the range declarations you listed without success. I also need this to be independent of any specific cell reference as myCol may be used across a wide range of columns in the worksheet.

Thanks for the help guys I appreciate it. I am so close to getting this running, it is frustrating to be stumped now.

 

[Fluff]

How about

sh.AutoFilter.Range.Offset(1).Columns(myCol).Resize(, 4).Copy

 

[rjplante]

Perfect, Thank you so very much.

 

[Fluff]

Glad we could help & thanks for the feedback