EXCEL VBA Find Headers and Copy Column from Sheet 1 to Sheet 2
Results 1 to 2 of 2

Thread: EXCEL VBA Find Headers and Copy Column from Sheet 1 to Sheet 2
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    New Member
    Join Date
    Feb 2016
    Posts
    3
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default EXCEL VBA Find Headers and Copy Column from Sheet 1 to Sheet 2

    I want to copy data from Sheet1 to Sheet2 based on headers in two sheets. The following code works great when both sheets’ headers are in first row. My question is if header in Sheet2 is in row 8, then how would my code be? thank you.

    Sub CopyData()
    Dim sws As Worksheet, dws As Worksheet
    Dim slr As Long, dlc As Long, c As Long, col As Long
    Dim colRng As Range, Rng As Range, Cell As Range
    Application.ScreenUpdating = False

    Set sws = Sheets("Sheet1")
    Set dws = Sheets("Sheet2")

    slr = sws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    dlc = dws.Cells(1, Columns.Count).End(xlToLeft).Column

    For c = 1 To dlc
    Set colRng = sws.Rows(1).Find(what:=dws.Cells(1, c), lookat:=xlWhole)
    If Not colRng Is Nothing Then
    col = colRng.Column
    sws.Range(sws.Cells(2, col), sws.Cells(slr, col)).Copy dws.Cells(2, c)
    End If
    Next c

    Application.ScreenUpdating = True
    End Sub

  2. #2
    MrExcel MVP AlphaFrog's Avatar
    Join Date
    Sep 2009
    Posts
    16,002
    Post Thanks / Like
    Mentioned
    14 Post(s)
    Tagged
    7 Thread(s)

    Default Re: EXCEL VBA Find Headers and Copy Column from Sheet 1 to Sheet 2

    Code:
    Sub CopyData()
    Dim sws As Worksheet, dws As Worksheet
    Dim slr As Long, dlc As Long, c As Long, col As Long
    Dim colRng As Range, Rng As Range, Cell As Range
    Application.ScreenUpdating = False
    
    Set sws = Sheets("Sheet1")
    Set dws = Sheets("Sheet2")
    
    slr = sws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    dlc = dws.Cells(8, Columns.Count).End(xlToLeft).Column
    
    For c = 1 To dlc
    Set colRng = sws.Rows(1).Find(what:=dws.Cells(8, c), lookat:=xlWhole)
    If Not colRng Is Nothing Then
    col = colRng.Column
    sws.Range(sws.Cells(2, col), sws.Cells(slr, col)).Copy dws.Cells(9, c)
    End If
    Next c
    
    Application.ScreenUpdating = True
    End Sub
    Last edited by AlphaFrog; Aug 14th, 2019 at 12:28 AM.
    Paste your Excel data to the forum...
    MrExcel HTML Maker or Excel Jeanie

    How to post your vba code
    [CODE]your VBA code here[/CODE]
    The # button in the forum's editor will apply CODE tags around your selected text.

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •