Scanning through multiple sheets and copying based on Header.

[ksp]

Hi all, I have a workbook with several sheets in it and I want the vba code to go through each sheet and look for the header (X,Y,Z) and copy the entire column and paste it in a new sheet (where headers are already placed in row1). I also would like the corresponding sheet names from each sheet to be copied in 4th column.

Have tried a lot online looking at smaller codes and make one final one but to no luck !! Any help on this would be appreciated.

[SamT]

Words fail to express your needs.

Please upload a sample workbook. it only needs three rows of data in each of the first three sheets. Use different data in each sheet. Manually fill the "Results" sheet with the data from the first three sheets according to the structure that you need

[ksp]

Hi SamT, please find a sample attachment. Data in the first 3 sheets is copied in the Result sheet. Have color coded it just for reference. Like mentioned, would like the code to go through each sheet, copy the data to Result sheet based on the Header.


Words fail to express your needs.

Please upload a sample workbook. it only needs three rows of data in each of the first three sheets. Use different data in each sheet. Manually fill the "Results" sheet with the data from the first three sheets according to the structure that you need

[ksp]

Hi SamT, please find a sample attachment. Data in the first 3 sheets is copied in the Result sheet. Have color coded it just for reference. Like mentioned, would like the code to go through each sheet, copy the data to Result sheet based on the Header. Also I forgot to mention that the 4th column should have sheet name from where its copied.

[jolivanes]

Where does the data from Sheet3, Column B go. I assume to Column B in Result Sheet. Is that right?

[jolivanes]

Since the Headers in all Sheets are in the same order, this should work.
Try it on a copy of your Workbook first though.

Sub Maybe()
Dim sh As Worksheet, j As Long
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "Result" Then
With sh
For j = 1 To 3
.Range(.Cells(2, j), .Cells(.Cells(.Rows.Count, j).End(xlUp).Row, j)).Copy Sheets("Result").Cells(Rows.Count, j).End(xlUp).Offset(1)
Next j
End With
End If
Next sh
End Sub

[jolivanes]

But you want the Sheet Names in Column D also.
Put a Header ("From Sheet" maybe) in Cell D1 of Sheet "Result" first.

Sub Maybe()
Dim sh As Worksheet, j As Long, shRes As Worksheet
Set shRes = Sheets("Result")
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "Result" Then
With sh
For j = 1 To 3
.Range(.Cells(2, j), .Cells(.Cells(.Rows.Count, j).End(xlUp).Row, j)).Copy shRes.Cells(Rows.Count, j).End(xlUp).Offset(1)
Next j
With shRes
.Range(.Cells(.Cells(.Rows.Count, 4).End(xlUp).Offset(1).Row, 4), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 4)).Value = sh.Name
End With
End With
End If
Next sh
End Sub

[ksp]

hi jolivanes, thank you so much for this however if I am not being too picky, the order in your code is fixed (although that's how I represented the data). Let me state what I want exactly cause it seems I did not put my problem correctly.

In each of the first 3 sheets there are 40 Headers and the ones I have listed are only 3 of them. So I want the code to only look for the headers I put in the result sheet and that set of data from each of the sheets(1 to 3) should be picked and pasted in the Result sheet along with Sheet name where it was picked in the 4th column.

Sorry for not being clear earlier. Whatever you shared works perfectly. Thnks again.



Since the Headers in all Sheets are in the same order, this should work.
Try it on a copy of your Workbook first though.

Sub Maybe()
Dim sh As Worksheet, j As Long
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "Result" Then
With sh
For j = 1 To 3
.Range(.Cells(2, j), .Cells(.Cells(.Rows.Count, j).End(xlUp).Row, j)).Copy Sheets("Result").Cells(Rows.Count, j).End(xlUp).Offset(1)
Next j
End With
End If
Next sh
End Sub

[jolivanes]

Try this (on a copy of your WB). Make sure you have something in Cell D1 in "Result" sheet.



Sub Maybe_Something_Like_This()
Dim shres As Worksheet, sh As Worksheet, lc As Long, i As Long
Dim a As String, b As Long
Set shres = Sheets("Result")
lc = shres.Cells(1, Columns.Count).End(xlToLeft).Column
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "Result" Then
For i = 1 To lc - 1
a = shres.Cells(1, i).Value
With sh
On Error GoTo Errorhandler
b = .Rows(1).Find(a, , , 1).Column
.Range(.Cells(2, b), .Cells(.Cells(.Rows.Count, b).End(xlUp).Row, b)).Copy shres.Cells(Rows.Count, i).End(xlUp).Offset(1)
End With
Errorhandler:
Next i
With shres
.Range(.Cells(.Cells(.Rows.Count, 4).End(xlUp).Offset(1).Row, 4), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 4)).Value = sh.Name
End With
End If
Next sh
End Sub

[Rafea1979]

Very useful