Copy filtered rows along with specific columns

[shwetankbhardwaj]

Hello there,

Hope you are creating magic in excel every day.

Below are the codes I have got, which creates a new worksheet (consolidate) and get data into the sheet from other worksheets.
It only fetches filtered rows and all the columns.

Sub copyfrmworksheet()

Dim wrk As Workbook
Dim sht As Worksheet
Dim trg As Worksheet
Dim cons_data As Worksheet
Dim rng As Range
Dim lastnonblank As Long
Dim wslastnonblank As Long
Dim colcount As Integer

Set wrk = ActiveWorkbook
'Set cons_data = ActiveWorkbook.Sheets("Consolidate_Data")

Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
trg.Name = "Consolidate"
Set sht = wrk.Worksheets(1)
colcount = sht.Cells(1, 255).End(xlToLeft).Column


For Each sht In wrk.Worksheets
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If

Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colcount))


lastnonblank = trg.Range("A:A").End(xlUp).Rows + 1

sht.Activate
rng.SpecialCells(xlCellTypeVisible).Select

Selection.Copy
trg.Activate

trg.Range("A65536").End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).PasteSpecial xlPasteValues

Next sht

trg.Columns.AutoFit

Application.ScreenUpdating = True

End Sub

What I need:-

I also want to add columns header in the 'consolidate' sheet. Which currently has no data. I want A1, B1, C1 and D1 as a column names.
As of now it is fetching all the columns from all the worksheets but I only need columns A, B, C and F from all worksheets.

Can someone please help me add codes (only for two tasks mentioned above) with the coding pasted above?

Thanks in advance!

Shwetank Bhardwaj

 

[mumps]

I think that your code can be simplified somewhat. What do you want as column names in A1, B1, C1 and D1? Do you want to copy all the data starting at row 2 from all the worksheets to the "Consolidate_Data" worksheet? Do you want to copy column A to column A, B to B, C to c and F to D?

 

[Fluff]

How about

Sub copyfrmworksheet()

Dim wrk As Workbook
Dim sht As Worksheet
Dim trg As Worksheet
Dim rng As Range

Set wrk = ActiveWorkbook
'Set cons_data = ActiveWorkbook.Sheets("Consolidate_Data")

Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
trg.name = "Consolidate"
trg.Range("A1:D1").Value = Array("A1", "B1", "C1", "D1")

For Each sht In wrk.Worksheets
   If sht.Index = wrk.Worksheets.Count Then Exit For
   
   Set rng = Intersect(sht.Range("A2", sht.Range("A" & Rows.Count).End(xlUp)).EntireRow, sht.Range("A:C,F:F"))
   lastnonblank = trg.Range("A:A").End(xlUp).Rows + 1
   
   rng.Copy
   trg.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues

Next sht

trg.Columns.AutoFit

Application.ScreenUpdating = True

End Sub

 

[shwetankbhardwaj]

Hi Fluff,

Thanks for looking into this and converted codes in the easy codes.

This works!

However there are small issues..

1. "lastnonblank = trg.Range("A:A").End(xlUp).Rows + 1" This coding is showing an error. It's working after removing. Is it okay?
2. There are some sheets where there can be no data but headers are present. I dont want the headers in 'consolidate' sheet as we just added (you added the codes)
3. In the above scenario, current coding fetch headers if there no data.

"Sub copyfrmworksheet()

Dim wrk As Workbook
Dim sht As Worksheet
Dim trg As Worksheet
Dim rng As Range


Set wrk = ActiveWorkbook
'Set cons_data = ActiveWorkbook.Sheets("Consolidate_Data")


Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
trg.Name = "Consolidate"
trg.Range("A1:D1").Value = Array("A1", "B1", "C1", "D1")


For Each sht In wrk.Worksheets
If sht.Index = wrk.Worksheets.Count Then Exit For

Set rng = Intersect(sht.Range("A2", sht.Range("A" & Rows.Count).End(xlUp)).EntireRow, sht.Range("A:C,F:F"))
'lastnonblank = trg.Range("A:A").End(xlUp).Rows + 1

rng.Copy
trg.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues


Next sht


trg.Columns.AutoFit


Application.ScreenUpdating = True


End Sub"

 

[Fluff]

Try this

For Each Sht In wrk.Worksheets
   If Sht.Index = wrk.Worksheets.Count Then Exit For
   If Sht.Range("A2") <> "" Then
      Set rng = Intersect(Sht.Range("A2", Sht.Range("A" & Rows.Count).End(xlUp)).EntireRow, Sht.Range("A:C,F:F"))
      rng.Copy
      trg.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
   End If
Next Sht

If A2 is blank it wont copy that across.

Also when posting code please use code tags, the # icon in the reply window.