CODEWITHSUNDEEP
excelvbacopy-paste
kit99
kit99

Reputation: 187

Copy columns by header names and paste to another workbook

Got this VBA to copy chosen columns from source, by column names:

Sub CopyColumnsByName()

    Dim CurrentWS As Worksheet
    Set CurrentWS = ActiveSheet

    Dim SourceWS As Worksheet
    Set SourceWS = Workbooks("UTTREKK.xlsx").Worksheets(1)
    Dim SourceHeaderRow As Integer: SourceHeaderRow = 1
    Dim SourceCell As Range, sRange As Range, Rng As Range

    Dim TWS As ThisWorkbook
    Dim TargetWS As Worksheet
    Set TargetWS = Workbooks("Target.xlsm").Worksheets("data")
    Dim TargetHeader As Range
    Set TargetHeader = TargetWS.Range("A1:AX1")

    Dim RealLastRow As Long
    Dim SourceCol As Integer


'COPY AND PASTE COLUMNS

'Column: id
    SourceWS.Activate
    lastCol = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
    Set sRange = Sheets(1).Range("A1", Cells(1, lastCol))
    With sRange
        Set Rng = .Find(What:="id", _
                        After:=.Cells(1), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            lastRow = Sheets(1).Cells(Rows.Count, Rng.Column).End(xlUp).Row
            Sheets(1).Range(Rng, Cells(lastRow, Rng.Column)).Copy
                TargetWS.Activate
                Sheets("data").Range("A1").PasteSpecial
        End If
    End With


'Column: sisteprosess
    SourceWS.Activate
    lastCol = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
    Set sRange = Sheets(1).Range("A1", Cells(1, lastCol))
    With sRange
        Set Rng = .Find(What:="sisteprosess", _
                        After:=.Cells(1), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            lastRow = Sheets(1).Cells(Rows.Count, Rng.Column).End(xlUp).Row
            Sheets(1).Range(Rng, Cells(lastRow, Rng.Column)).Copy
                TargetWS.Activate
                Sheets("data").Range("B1").PasteSpecial
        End If
    End With


'Column: hendelse
    SourceWS.Activate
    lastCol = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
    Set sRange = Sheets(1).Range("A1", Cells(1, lastCol))
    With sRange
        Set Rng = .Find(What:="hendelse", _
                        After:=.Cells(1), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            lastRow = Sheets(1).Cells(Rows.Count, Rng.Column).End(xlUp).Row
            Sheets(1).Range(Rng, Cells(lastRow, Rng.Column)).Copy
                TargetWS.Activate
                Sheets("data").Range("C1").PasteSpecial
        End If
    End With


End Sub

It works, but there are two issues I can't figure out:

  1. How can I copy columns from row 2 and down to last row? Headers is alredy in my target cells.

  2. My VBA is based on repeating the same bit of code for each column. Is it possible to modify this in such a way that I can define source column names and target column range at top, and run the same code in loop. I don't know how to write such a code, but I got 30 + columns and it seems as a waste to copy the code 30 times...

And as a bonus: My code copies data down to last used row for each column. However, some columns do have blank cells. This is not a big issue, but is it possible to set "last row range" for all columns to copy to be last row in column A? This column holds data in all 50000 cells.

Upvotes: 1

Views: 1842

Answers (1)

Pᴇʜ
Pᴇʜ

Reputation: 57683

Define an array with your column names ColumnNameList = Array("id", "sisteprosess", "hendelse") and then loop through it.

You need also a counter PasteColumn to move to the next column for pasting in your data worksheet. Note that this will start in column A of your data worksheet then paste to B, C, ….

Also don't use .Activate as you already set your worksheets to variables SourceWS and TargetWS you can use them without activating dircetcy.

You can use .Offset(RowOffset:=1) to move from your found header one row down so it starts in row 2 to copy data only (without header).

Option Explicit

Public Sub CopyColumnsByName()   
    Dim SourceWS As Worksheet
    Set SourceWS = Workbooks("UTTREKK.xlsx").Worksheets(1)

    Dim TargetWS As Worksheet
    Set TargetWS = Workbooks("Target.xlsm").Worksheets("data")

'COPY AND PASTE COLUMNS
    Dim LastRowA As Long  'last row in col A (use for all copy actions)
    LastRowA = SourceWS.Cells(SourceWS.Rows.Count, "A").End(xlUp).Row

    Dim LastCol As Long   'last column for search
    LastCol = SourceWS.Cells(1, SourceWS.Columns.Count).End(xlToLeft).Column

    Dim SearchRange As Range  'define search range for column name
    Set SearchRange = SourceWS.Range("A1", SourceWS.Cells(1, LastCol))

    Dim ColumnNameList() As Variant
    ColumnNameList = Array("id", "sisteprosess", "hendelse")  'your columns list

    Dim PasteColumn As Long
    PasteColumn = 1 'start pasting in column 1 of your data worksheet

    Dim ColumnName As Variant
    For Each ColumnName In ColumnNameList
        With SearchRange
            Dim FoundAt As Range
            Set FoundAt = .Find(What:=ColumnName, _
                            After:=.Cells(1), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False)
            If Not FoundAt Is Nothing Then
                SourceWS.Range(FoundAt.Offset(RowOffset:=1), SourceWS.Cells(LastRowA, FoundAt.Column)).Copy Destination:=TargetWS.Cells(2, PasteColumn)
                PasteColumn = PasteColumn + 1 'move to next paste column
            End If
        End With
    Next ColumnName
End Sub

Note that here the list of columns ColumnNameList = Array("id", "sisteprosess", "hendelse") is hardcoded. If you already have them in your destination you can better read them from there instead of writing them into your code.

ColumnNameList = TargetWS.Range("A1", TargetWS.Cells(1, TargetWS.Columns.Count).End(xlToLeft)).Value

Upvotes: 1

Related Questions