copy from one sheet to another sheet based on column names

[aravindhan_3]

Hi,

Good Evening everyone! need a help with the macro

I have sales data in sheet2 ( about 160 columns & half a million rows of data I used a recorded macro to filter this data , now have the data with filter)

I wanted to copy these filtered data to sheet 1, but only few columns ( I have all those column names in sheet 1 row 1)

I am using this code to find each column names and bring back data, but this is taking hell loads of time. is there a better way in VBA to do this?



For x = 0 To 54
Range("C4").Select
ActiveCell.Offset(0, x).Activate
Selection.Copy
ranval = ActiveCell.Value
Sheets("Roster").Select
Cells.Find(What:=ranval, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(lr, 0)).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Range("A1").Select
Sheets("Base Sheet").Select
ActiveCell.Offset(0, 0).Activate
If Selection.Value <> 0 Then
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
ActiveCell.Offset(0, 0).Select
Next

[excelliot]

are you trying to put all filtered data from multiple columns to single column one after another?

[excelliot]

bump ...:hi:

[aravindhan_3]

Hi,

No, I need to copy them in columns B, C D E etc. (I have column names in my output sheet in row 1), my filtered data I might have 200 columns, but in my output sheet I need only 50 columns which are there in row 1

I need t copy only visible cells from each column n paste them in my output sheet columns.
Regards
Arvind

[excelliot]

can you attach sample file with test data?

[excelliot]

see what i am assuming here that you want to copy data from Roster sheet to base sheet, Roster sheet has many columns and data is filtered in to. In Base sheet you have few of the column matching header to roster sheet and you want to copy filtered data in base sheet from roster for each matching headers when you run macro..

try below code:



Option Explicit

Sub Macro1()
Dim Rng As Range, c As Range
Dim sCell As Range
Dim rSize As Long


Sheets("Base Sheet").Select
Set Rng = Range([A1], [A1].End(xlToRight))

For Each c In Rng
Set sCell = Sheets("Roster").Range("1:1").Find(What:=c.Value, LookIn:=xlValues)
rSize = Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count


If c.Offset(1, 0).Value <> "" Then
c.End(xlDown).Offset(1, 0).Resize(rSize, 1).Value = Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible)
Else
c.Offset(1, 0).Resize(rSize, 1).Value = Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible)
End If


Next


End Sub




Cheers!!

[aravindhan_3]

Hi,

Sorry for coming back so late. the above code is not working for me:( attached the sample file. its not giving neither any error nor result

can you please help me with this..

Regards
Arvind

[excelliot]

Hi, try this code;



Option Explicit
Sub Macro1()
Dim Rng As Range, c As Range
Dim sCell As Range
Dim rSize As Long
Sheets("Base Sheet").Select
Set Rng = Range([D1], [D1].End(xlToRight))
For Each c In Rng
Set sCell = Sheets("Roster").Range("1:1").Find(What:=c.Value, LookIn:=xlValues)
rSize = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count
If c.Offset(1, 0).Value <> "" Then
c.End(xlDown).Offset(1, 0).Resize(rSize, 1).Value = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value
Else
c.Offset(1, 0).Resize(rSize, 1).Value = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value
End If
Next
End Sub


Cheers!!

[aravindhan_3]

Hi,

Thanks for your help, this works if the data is not filtered in the roster tab & giving me #NA for some reason.

Please help
Arvind

[excelliot]

Hi,

Thanks for your help, this works if the data is not filtered in the roster tab & giving me #NA for some reason.

Please help
Arvind

yo, i see now..

check this amended code:



Option Explicit
Sub Macro1()
Dim Rng As Range, c As Range
Dim sCell As Range
Dim rSize As Long
Dim dest As Range
Sheets("Base Sheet").Select
Set Rng = Range([D1], [D1].End(xlToRight))
For Each c In Rng
Set sCell = Sheets("Roster").Range("1:1").Find(What:=c.Value, LookIn:=xlValues)
rSize = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count
If c.Offset(1, 0).Value <> "" Then
'c.End(xlDown).Offset(1, 0).Resize(rSize, 1) = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value
Set dest = c.End(xlDown).Offset(1, 0)
Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
dest.Select
ActiveSheet.Paste
Else
'c.Offset(1, 0).Resize(rSize, 1).Value = Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value
Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
Set dest = c.Offset(1, 0)
dest.Select
ActiveSheet.Paste
End If
Next
End Sub

[aravindhan_3]

Hi,
it worked perfectly, just one think, if the column names in base sheet is not there in roster, the macro gives debug error, instead I has to proceed with other columns,

I have to insert few columns in between just to do some calculations based on the output. for example, Salary & Inc% comes from roster, and I want to insert column "Increase amount" in my base sheet, this macro is trying to find out this column and gives error.

Thanks for your help
Regards
Arvind

[excelliot]

in that case use this:



Option Explicit
Sub Macro1()
Dim Rng As Range, c As Range
Dim sCell As Range
Dim rSize As Long
Dim dest As Range
Sheets("Base Sheet").Select
Set Rng = Range([D1], [D1].End(xlToRight))
For Each c In Rng
Set sCell = Sheets("Roster").Range("1:1").Find(What:=c.Value, LookIn:=xlValues)
If Not sCell Is Nothing Then
rSize = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count
If c.Offset(1, 0).Value <> "" Then
'c.End(xlDown).Offset(1, 0).Resize(rSize, 1) = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value
Set dest = c.End(xlDown).Offset(1, 0)
Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
dest.Select
ActiveSheet.Paste
Else
'c.Offset(1, 0).Resize(rSize, 1).Value = Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value
Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
Set dest = c.Offset(1, 0)
dest.Select
ActiveSheet.Paste
End If
End If
Next
End Sub


Cheers!!

[excelliot]

if your query is solved mark this thread as completed..

[aravindhan_3]

Hi,

Sorry the delay in response, I tried with your new code it works, but not giving the correct result,

the code finds the column name, and gives result, but I think it not doing the exact column names,
I have the column header as Code & Code description in my roster tab & Base sheet, but the macro is pasting the same result for both the column,
I tried changing this line



Set sCell = Sheets("Roster").Range("1:1").Find(What:=c.Value, LookIn:=xlValues)
to



Set sCell = Sheets("Roster").Range("1:1").Find(What:=c.Value, LookIn:=xlValues, matchcase:=False) still same problem:(

thanks for your help

[excelliot]

how many columns you have with same name, mention it & also is it same in both the sheets?

[excelliot]

if two column headers are same, you can use find next to derive value from second header

[aravindhan_3]

max five, however they are not same, similar words like Code & code description, some times I might have code 1, code 2 Code 3 Etc, so instead of finding match case it has to find exact word
Regards
Arvind

[excelliot]

Ok, change line to:


Set sCell = Sheets("Roster").Range("1:1").Find(What:=c.Value, LookIn:=xlValues, LookAt:= xlWhole)

[excelliot]

check this attachment..and also note revised code which takes care of last row for blank cells..

new code



Option Explicit
Sub Macro1()
Dim Rng As Range, c As Range
Dim sCell As Range
Dim rSize As Long
Dim dest As Range
Dim lDestRow As Long
Dim i As Integer

Sheets("Base Sheet").Select
i = 0
Set Rng = Range([D1], [D1].End(xlToRight))
For Each c In Rng
Set sCell = Sheets("Roster").Range("1:1").Find(What:=c.Value, LookIn:=xlValues, LookAt:=xlWhole)
rSize = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count
If c.Offset(1, 0).Value <> "" Then
Set dest = c.End(xlDown).Offset(1, 0)
If i = 0 Then
lDestRow = dest.Row
End If

If dest.Row < lDestRow Then
Set dest = Cells(lDestRow, dest.Column)
End If

Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
dest.Select
ActiveSheet.Paste
Else
Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
Set dest = c.Offset(1, 0)

If dest.Row < lDestRow Then
Set dest = Cells(lDestRow, dest.Column)
End If

dest.Select
ActiveSheet.Paste
End If
i = i + 1
Next
End Sub

[venkatraj]

Hi, with above code I want only the highlighted rows should get moved from Roster to Base Sheet. For an example, Sheet 2 has multiple columns and Sheet 1 will have only 5 or 6 column with headers of Sheet2. With above script, Sheet 1 will pull the complete row; based on the headers of Sheet 2 (Ex: 10). Now, I need to modify the script a bit where it will pull only highlighted(in Red) Rows from Sheet 2 based on the headers(Ex: 2 rows). Could you please help

[juville]

check this attachment..and also note revised code which takes care of last row for blank cells..

new code



Option Explicit
Sub Macro1()
Dim Rng As Range, c As Range
Dim sCell As Range
Dim rSize As Long
Dim dest As Range
Dim lDestRow As Long
Dim i As Integer

Sheets("Base Sheet").Select
i = 0
Set Rng = Range([D1], [D1].End(xlToRight))
For Each c In Rng
Set sCell = Sheets("Roster").Range("1:1").Find(What:=c.Value, LookIn:=xlValues, LookAt:=xlWhole)
rSize = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count
If c.Offset(1, 0).Value <> "" Then
Set dest = c.End(xlDown).Offset(1, 0)
If i = 0 Then
lDestRow = dest.Row
End If

If dest.Row < lDestRow Then
Set dest = Cells(lDestRow, dest.Column)
End If

Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
dest.Select
ActiveSheet.Paste
Else
Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
Set dest = c.Offset(1, 0)

If dest.Row < lDestRow Then
Set dest = Cells(lDestRow, dest.Column)
End If

dest.Select
ActiveSheet.Paste
End If
i = i + 1
Next
End Sub





Hi there,

i would like to ask if there's blank cells on row 20, why doesn't the data populates on row 21 onwards?

Anyway to change the coding for that?