Copy filtered rows along with specific columns

shwetankbhardwaj

New Member
Joined
Apr 26, 2017
Messages
20
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.

Code:
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
 
Last edited by a moderator:

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
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?
 
Upvote 0
How about
Code:
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
 
Upvote 0
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"
 
Upvote 0
Try this
Code:
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.
 
Upvote 0

Forum statistics

Threads
1,213,504
Messages
6,114,016
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top