macro to retrieve data based on column headers

[cjcass]

Hi,
I'm looking for some vba that will retrieve data from a table in one wksht and drop it into a table on another. Looking at the picture below, I would like to be able to enter header values in the cells C5:Q5 in the 'Report' wksht then press the button to execute a macro that will retrieve the data corresponding to the headers in the table in the 'Data' wksht.
Notes:
The Data wksht headers are fixed from A3:AE3
The Data wksht table will vary in size (up to 50,000 rows down)
Not all cells in the Report wksht (C5:Q5) will have entries in them
Any help much appreciated.
Rgds,

 

[wideboydixon]

Public Sub CopyDataToReport()

Dim dataSheet As Worksheet
Dim reportSheet As Worksheet
Dim lastRow As Long
Dim thisCol As Long
Dim thatCol As Variant

Set dataSheet = Sheets("Data")
Set reportSheet = Sheets("Report")

With reportSheet
    For thisCol = .Range("C5").Column To .Range("Q5").Column
        lastRow = .Cells(Rows.Count, thisCol).End(xlUp).Row
        If lastRow > 5 Then .Range(.Cells(6, thisCol), .Cells(lastRow, thisCol)).ClearContents
        If .Cells(5, thisCol).Value <> "" Then
            thatCol = Application.Match(.Cells(5, thisCol).Value, dataSheet.Range("A3:AE3"), 0)
            If Not IsError(thatCol) Then
                lastRow = dataSheet.Cells(dataSheet.Rows.Count, thatCol).End(xlUp).Row
                dataSheet.Range(dataSheet.Cells(4, thatCol), dataSheet.Cells(lastRow, thatCol)).Copy Destination:=.Cells(6, thisCol)
            End If
        End If
    Next thisCol
End With

End Sub

WBD

 

[ranman256]

adjust your sheet names accordingly

'----------
Sub CopyDataOver()
'----------
Dim vHdr
Dim shtTarg As Worksheet, shtSrc As Worksheet
Dim c As Long, iSrcCol As Long
Dim sColLtr As String


Set shtSrc = Sheets("sheet1")   'the source data


Worksheets.Add
Set shtTarg = ActiveSheet   'target data


Sheets("report").Activate          'what headers to copy c5:Q5
Range("C5").Select
While ActiveCell.Value <> ""
   c = c + 1
   vHdr = ActiveCell.Value
   iSrcCol = FindHdr(vHdr)
   sColLtr = Mid(ActiveCell.Address, 2, InStrRev(ActiveCell.Address, "$") - 2)
   
   If iSrcCol > 0 Then
       shtSrc.Activate
       Columns(sColLtr & ":" & sColLtr).Select
       Selection.Copy
       shtTarg.Activate
       Range("A1").Offset(0, c - 1).Select
       ActiveSheet.Paste
   End If
   
   Sheets("report").Activate
   ActiveCell.Offset(0, 1).Select   'next col
Wend
Set shtSrc = Nothing
Set shtTarg = Nothing
End Sub


'----------
Function FindHdr(ByVal pvName)
'----------
On Error GoTo ErrFind
    Sheets("sheet1").Activate
    Rows("3:3").Select
    Selection.Find(What:=pvName, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        
    FindHdr = ActiveCell.Column
Exit Function
ErrFind:
FindHdr = 0
End Function

 

[cjcass]

Awesome!, works perfectly, thanks very much indeed