CODEWITHSUNDEEP
excelvba
n_07
n_07

Reputation: 21

Looking for specific column headers in all worksheets of a workbook

I am trying to create a Macro that will look through all the worksheets in a workbook and find the column named "ID". There will be an "ID" column in most of the worksheets, but the header may not necessarily be in row 1. Once the column has been found I would like to copy all the data in that column to a new worksheet. When copying the data over to a new worksheet I would like the data to be copied all in column A in the new worksheet- so would like the data to be copied into the next blank cell. So far this is what I have got 

Sub Test()

Dim ws As Worksheet
Dim sString As String
Dim sCell As Variant
Dim cfind As Range
Dim j As Integer

  For Each ws In Worksheets
    If ws.Name = "Archive" Then GoTo nextws
    ws.Activate
    j = ActiveSheet.Index
    'MsgBox j
    On Error Resume Next
    Set cfind = Cells.Find(what:="ID", lookat:=xlWhole)
    If Not cfind Is Nothing Then
      cfind.EntireColumn.Copy
      Worksheets("Archive").Range("A1").Offset(0, j - 1).PasteSpecial
    End If
  nextws:
  Next ws

End Sub

I cant seem to get the last bit right that pastes the data. At the moment it just pastes it in the next available column.

Upvotes: 2

Views: 1233

Answers (2)

Tim Williams
Tim Williams

Reputation: 166790

This will line up the ID headers on row 1:

Sub Test()

    Const SHT_ARCHIVE As String = "Archive"

    Dim ws As Worksheet
    Dim cfind As Range, rngList As Range
    Dim j As Integer

    j = 0
    For Each ws In Worksheets
        If ws.Name <> SHT_ARCHIVE Then
            j = j + 1
            Set cfind = ws.UsedRange.Find(what:="ID", lookat:=xlWhole, LookIn:=xlValues)
            If Not cfind Is Nothing Then
                Set rngList = Range(cfind, ws.Cells(Rows.Count, cfind.Column).End(xlUp))
                Worksheets(SHT_ARCHIVE).Cells(1, j).Resize(rngList.Rows.Count, 1).Value = rngList.Value
            End If
        End If
    Next ws
End Sub

Upvotes: 1

Dante May Code
Dante May Code

Reputation: 11247

So, you want all in Column A, right?

Change to

With Worksheets("Archive")
  If .Range("A1") = "" Then
    .Range("A1").PasteSpecial
  Else
    .Range("A1").Offset(.UsedRange.Rows.Count).PasteSpecial
  End If
End With

from

Worksheets("Archive").Range("A1").Offset(0, j - 1).PasteSpecial

Upvotes: 4

Related Questions