Extract columns based on Column name

[Miguelluis]

Hi,

I've got a workbook with over 150 sheets all in different layouts. I need to extract two columns from all of the different sheets into one, the two columns are titled 'ID Client' and 'ID Holder' and unfortunately some rows are blank and the columns are not in the same position for all the sheets and contain numbers and text.

Is there a way to extract all this data into one sheet and have it copied down, similar to the append option. They can be extracted to a new sheet in the same workbook.

Many thanks
Miguel

 

[Fluff]

How about

Sub CopyCols()
   Dim Ws As Worksheet
   Dim Sws As Worksheet
   Dim Fnd1 As Range
   Dim Fnd2 As Range
   
   Sheets.Add(Sheets(1)).Name = "Summary"
   Set Sws = Sheets("Summary")
   For Each Ws In Worksheets
      If Not Ws.Name = "Summary" Then
         Set Fnd1 = Ws.Range("1:1").Find("ID Client", , , xlWhole, , , False, , False)
         Set Fnd2 = Ws.Range("1:1").Find("ID Holder", , , xlWhole, , , False, , False)
         Intersect(Ws.UsedRange, Fnd1.EntireColumn).Copy Sws.Range("A" & Rows.Count).End(xlUp).Offset(1)
         Intersect(Ws.UsedRange, Fnd2.EntireColumn).Copy Sws.Range("B" & Rows.Count).End(xlUp).Offset(1)
      End If
   Next Ws
End Sub

 

[Miguelluis]

I think it's nearly there, however, I get a runtime error 91 on this line:

Intersect(Ws.UsedRange, Fnd1.EntireColumn).Copy Sws.Range("A" & Rows.Count).End(xlUp).Offset(1)

 

[Fluff]

Are your headers in row 1?
It sounds like the code can't find ID Client

 

[Miguelluis]

When I run the Macro it creates the Summary sheet but copies the column header into row 2. All existing headers are on row 1.

 

[Fluff]

OK, how about

Sub CopyCols()
   Dim Ws As Worksheet
   Dim Sws As Worksheet
   Dim Fnd1 As Range
   Dim Fnd2 As Range
   
   Sheets.Add(Sheets(1)).Name = "Summary"
   Set Sws = Sheets("Summary")
   Sws.Range("A1:B1").Value = Array("ID Client", "ID Holder")
   For Each Ws In Worksheets
      If Not Ws.Name = "Summary" Then
         Set Fnd1 = Ws.Range("1:1").Find("ID Client", , , xlWhole, , , False, , False)
         Set Fnd2 = Ws.Range("1:1").Find("ID Holder", , , xlWhole, , , False, , False)
         Intersect(Ws.UsedRange.Offset(1), Fnd1.EntireColumn).Copy Sws.Range("A" & Rows.Count).End(xlUp).Offset(1)
         Intersect(Ws.UsedRange.Offset(1), Fnd2.EntireColumn).Copy Sws.Range("B" & Rows.Count).End(xlUp).Offset(1)
      End If
   Next Ws
End Sub

 

[Miguelluis]

It now puts the header in row 1, however, it stops merging/extracting after 5 or 6 sheets and gives me the same error.

 

[Fluff]

When you get the error, check which sheet the code is looking at & make sure you have both headers in row 1 of that sheet.

 

[Miguelluis]

Hi,

I found that it stops when it gets to a sheet that does not contain the header. I looked at this and some sheets do not contain the headers, is it possible to add something where if the header is not found it moves to the next sheet?

Thanks
Miguel

 

[Fluff]

Modify the last 2 lines like

         [COLOR=#ff0000]If Not Fnd1 Is Nothing Then [/COLOR]Intersect(Ws.UsedRange.Offset(1), Fnd1.EntireColumn).Copy Sws.Range("A" & Rows.Count).End(xlUp).Offset(1)
        [COLOR=#ff0000] If Not Fnd2 Is Nothing Then [/COLOR]Intersect(Ws.UsedRange.Offset(1), Fnd2.EntireColumn).Copy Sws.Range("B" & Rows.Count).End(xlUp).Offset(1)