Copy to Another

[billandrew]

Looking to copy 6 columns which are not adjacent to each other, if cell value = a specific criteria to another Workbook starting in Column K.
The column row height could change when received.

The order on the copied "Master" sheet is
- Column B
- Column C
- Column I
- Column J
- Column E
- Column F


Hope this provides the necessary info.

 

[Fluff]

How about this mod to mumps code

Sub CopyCols()
    Application.ScreenUpdating = False
    Dim bottomA As Long
    bottomA = Range("A" & Rows.Count).End(xlUp).Row
    Range("A1:J" & bottomA).AutoFilter Field:=3, Criteria1:="=Central", Operator:=xlOr, Criteria2:="=North"
    Intersect(Rows("2:" & bottomA), Range("B:B,C:C,I:I,J:J")).Copy Workbooks("Daily Report.xlsx").Sheets("Sheet1").Cells(Rows.Count, "K").End(xlUp).Offset(1, 0)
    Intersect(Rows("2:" & bottomA), Range("E:F")).Copy Workbooks("Daily Report.xlsx").Sheets("Sheet1").Cells(Rows.Count, "O").End(xlUp).Offset(1, 0)
    If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
    Application.ScreenUpdating = True
End Sub

 

[billandrew]

Awesome - Works Great!

Can I bother now, probably heard this before.

Like to Filter & Copy "West" Criteria to workbook "Daily Report" Sheet2 & "East" Criteria to workbook "Daily Report" Sheet3. Same order of columns as above. Is it simply copying the supplied code and changing the Criteria and Worksheets copied to?

 

[Fluff]

How about

Sub CopyCols()
   Dim bottomA As Long
   Dim Ary As Variant
   Dim i As Long
   
   Ary = Array("North|Central", "Sheet1", "West", "sheet2", "East", "Sheet3")
   Application.ScreenUpdating = False
   With ActiveSheet
      bottomA = .Range("A" & Rows.Count).End(xlUp).Row
      If .AutoFilterMode Then .AutoFilterMode = False
      For i = 0 To UBound(Ary) Step 2
         Range("A1:J1").AutoFilter 3, Split(Ary(i), "|"), xlFilterValues
         Intersect(Rows("2:" & bottomA), Range("B:B,C:C,I:I,J:J")).Copy Workbooks("Daily Report.xlsx").Sheets(Ary(i + 1)).Cells(Rows.Count, "K").End(xlUp).Offset(1, 0)
         Intersect(Rows("2:" & bottomA), Range("E:F")).Copy Workbooks("Daily Report.xlsx").Sheets(Ary(i + 1)).Cells(Rows.Count, "O").End(xlUp).Offset(1, 0)
      Next i
      .AutoFilterMode = False
   End With
End Sub

 

[billandrew]

Thank You

There is one problem, if there is no specific criteria then the entire data is copied.

Ex. Column C = "East" and there are no cell values with East.

 

[Fluff]

Try

Sub CopyCols()
   Dim bottomA As Long
   Dim Ary As Variant
   Dim i As Long
   
   Ary = Array("North|Central", "Sheet1", "West", "sheet2", "East", "Sheet3")
   Application.ScreenUpdating = False
   With ActiveSheet
      bottomA = .Range("A" & Rows.Count).End(xlUp).Row
      If .AutoFilterMode Then .AutoFilterMode = False
      For i = 0 To UBound(Ary) Step 2
         Range("A1:J1").AutoFilter 3, Split(Ary(i), "|"), xlFilterValues
         Intersect(Rows("2:" & bottomA), Range("B:B,C:C,I:I,J:J")).SpecialCells(xlVisible).Copy Workbooks("Daily Report.xlsx").Sheets(Ary(i + 1)).Cells(Rows.Count, "K").End(xlUp).Offset(1, 0)
         Intersect(Rows("2:" & bottomA), Range("E:F")).SpecialCells(xlVisible).Copy Workbooks("Daily Report.xlsx").Sheets(Ary(i + 1)).Cells(Rows.Count, "O").End(xlUp).Offset(1, 0)
      Next i
      .AutoFilterMode = False
   End With
End Sub

 

[billandrew]

Fluff

Now returns a Run Time Error '1004' No cells were found.

The Break occurs at the first Intersect.

 

[Fluff]

How about

Sub CopyCols()
   Dim bottomA As Long
   Dim Ary As Variant
   Dim i As Long
   
   Ary = Array("North|Central", "Sheet1", "West", "sheet2", "East", "Sheet3")
   Application.ScreenUpdating = False
   With ActiveSheet
      bottomA = .Range("A" & Rows.Count).End(xlUp).Row
      If .AutoFilterMode Then .AutoFilterMode = False
      For i = 0 To UBound(Ary) Step 2
         Range("A1:J1").AutoFilter 3, Split(Ary(i), "|"), xlFilterValues
         On Error Resume Next
         Intersect(Rows("2:" & bottomA), Range("B:B,C:C,I:I,J:J")).SpecialCells(xlVisible).Copy Workbooks("Daily Report.xlsx").Sheets(Ary(i + 1)).Cells(Rows.Count, "K").End(xlUp).Offset(1, 0)
         Intersect(Rows("2:" & bottomA), Range("E:F")).SpecialCells(xlVisible).Copy Workbooks("Daily Report.xlsx").Sheets(Ary(i + 1)).Cells(Rows.Count, "O").End(xlUp).Offset(1, 0)
         On Error GoTo 0
      Next i
      .AutoFilterMode = False
   End With
End Sub

 

[billandrew]

Awesome Fluff - Thank You so much

 

[Fluff]

You're welcome