CODEWITHSUNDEEP
vbaexcel
excelguy
excelguy

Reputation: 1624

VBA, Copy values from one sheet to another using header names

I want to copy values from sheet A to Sheet B but have it loop through the headers in both sheets, find the headers in sheet B and paste values from Sheet A into B based on headers. The reason behind this is that headers are not in the same column name so a straight copy and paste won't work.

I have the piece that copies and pastes it normally. But how can I get it to loop through the existing headers in Sheet B , headers will be predefined in row 1. Stuck at the copy and paste part.

    Sub stack()

Dim i As Integer
Dim y As Integer
Dim src As Range
Dim tgt As Range
Dim Headloop As String
Dim Headloop2 As String

Set src = Sheets("sheet1")  'source sheet
Set tgt = Sheets("sheet2")   'destination sheet

With tgt
For i = 1 To max_col
    Headloop = Range(i & "1").value 'i is column Number, "1" is row 1
Next i
End With

With src
For y = 1 To max_col
    Headloop2 = Range(y & "1").value 'y is column Number, "1" is row 1
Next y
End With

 For Each i In tgt
    If Headloop > 0 Then
    Range(y&"2"),src.Copy Destination: = tgt.range(i&"2").value
    End If
Next i


End Sub

thanks.

Upvotes: 0

Views: 1561

Answers (2)

QHarr
QHarr

Reputation: 84465

Here is a basic principle example.

I assume the source headers are in row 1 of sheet 1 so use:

Intersect(.Rows(1), .UsedRange).SpecialCells(xlCellTypeConstants)

to find all the headers in that row and loop over them.

Each source header is the current rng.Value.

I use Find to match this against row 1 of sheet2. 

trgt.Rows(1).Find(rng.Value, LookIn:=xlValues, lookat:=xlWhole)

If found then copy the data under the heading:

If Not trgtCell Is Nothing Then
                .Range(rng.Offset(1), .Cells(.Rows.Count, rng.Column).End(xlUp)).Copy

I used the matched cell, trgtCell, to determine the column to paste to.

I paste to the next available row in that column using 

 .Cells(.Rows.Count, trgtCell.Column).End(xlUp).Row + 1

Code:

Option Explicit
Sub CopyByHeaders()
    Dim rng As Range, trgtCell As Range, src As Worksheet, trgt As Worksheet
    Set src = Worksheets("Sheet1")
    Set trgt = Worksheets("Sheet2")
    Application.ScreenUpdating = False
    With src
        For Each rng In Intersect(.Rows(1), .UsedRange).SpecialCells(xlCellTypeConstants)       
            Set trgtCell = trgt.Rows(1).Find(rng.Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not trgtCell Is Nothing Then
                .Range(rng.Offset(1), .Cells(.Rows.Count, rng.Column).End(xlUp)).Copy
                With trgt
                    .Range(Split(trgtCell.Address, "$")(1) & .Cells(.Rows.Count, trgtCell.Column).End(xlUp).Row + 1).PasteSpecial
                End With
            End If
        Next rng
    End With
    Application.ScreenUpdating = True
End Sub

To just paste to row 2 of destination use:

 .Range(Split(trgtCell.Address, "$")(1) & 2).PasteSpecial

Upvotes: 1

David Zemens
David Zemens

Reputation: 53623

Untested, but the idea here is to iterate the cells in the destination sheet's Header row (For h = 1 to destination.Cells.Count), then use the Index function to obtain the corresponding column number on the source data sheet (or an error, if that column doesn't exist). Then it's simply copy/paste.

Dim s1 as Worksheet, s2 as Worksheet
Dim dataToCopy as Range, sourceData as Range, destination as Range
Dim h as Long, headerName as String
Dim columnNumber as Variant

Set s1 = Worksheets("Sheet1")           'modify as needed
Set s2 = Worksheets("Sheet2")           'modify as needed
Set destination = s2.Range("A1:A" & max_col) 
Set sourceData = s2.Range("A1:Z100")    'modify as needed

For h = 1 to destination.Cells.Count
    headerName = destination.Cells(1,h).Value
    columnNumber = Application.Index(headerName, sourceData.Rows(1), False)
    If IsError(columnNumber) Then
        ' this header wasn't found
        MsgBox headerName & " is not found on the source sheet!", vbCritical
    Else
        Set dataToCopy = sourceData.Columns(columnNumber)
        ' skip the header row
        Set dataToCopy = dataToCopy.Resize(sourceData.Rows.Count - 1).Offset(1)
        dataToCopy.Copy destination.Cells(1,h).Offset(1)
    End If
Next

Upvotes: 1

Related Questions