Copy/Paste columns

Question

I have several columns with headers in one excel workbook, I want to copy some of these columns into another workbook.

Let’s say I have my origin workbook:

Ident|Name|Code|Part|Desc|U|Total

These are the headers of the columns with some data below them.

And I want to copy only the data in the columns Ident, Code and Part in another workbook that has the same headers but in a different order with the exception that one header has a different name:

Code|Ident|Piece

It is blank and Piece corresponds to Part. So I want a code that takes the data from the origin workbook and copy it to the destination workbook. Also if possible I’d like that you can choose the original workbook from a file as I have different excel files to choose from.

Thank you for your answers. I have never used VBA and I’m trying to learn.

I have the following code that lets you choose the data you want manually but I want something similar that does it automatically after recognizing the headers.

Sub ImportDatafromotherworksheet()
Dim wkbCrntWorkBook As Workbook
Dim wkbSourceBook As Workbook
Dim rngSourceRange As Range
Dim rngDestination As Range
Set wkbCrntWorkBook = ActiveWorkbook
With Application.FileDialog(msoFileDialogOpen)
    .Filters.Clear
    .Filters.Add "Excel 2007-13", "*.xlsx; *.xlsm; *.xlsa"
    .AllowMultiSelect = False
    .Show
    If .SelectedItems.Count > 0 Then
        Workbooks.Open .SelectedItems(1)
        Set wkbSourceBook = ActiveWorkbook
        Set rngSourceRange = Application.InputBox(prompt:="Select source range", Title:="Source Range", Default:="A1", Type:=8)
        wkbCrntWorkBook.Activate
        Set rngDestination = Application.InputBox(prompt:="Select destination cell", Title:="Select Destination", Default:="A1", Type:=8)
        rngSourceRange.Copy rngDestination
        rngDestination.CurrentRegion.EntireColumn.AutoFit
        wkbSourceBook.Close False
    End If
End With
End Sub

I add here some part I modified:

 arrC = Split("CODE|ident|Piece", "|")
 lastColO = shO.Cells(1, Cells.Columns.Count).End(xlToLeft).Column
 arrO = shO.Range(shO.Cells(1, 1), shO.Cells(1, lastColO)).Value
 'Copy the columns:
arrC = Split("CODE|ident|Piece", "|")
lastColO = shO.Cells(1, Cells.Columns.Count).End(xlToLeft).Column
arrO = shO.Range(shO.Cells(1, 1), shO.Cells(1, lastColO)).Value
 'Copy the columns:
 For j = 0 To UBound(arrC)
    If arrC(j) = "Ident" Then strH = "ident" Else strH = arrC(j)
    If arrC(j) = "Code" Then strH = "CODE" Else strH = arrC(j)
    If arrC(j) = "Piece" Then strH = "Part" Else strH = arrC(j)
For i = 1 To UBound(arrO, 2)
    If arrO(1, i) = strH Then
        lastRowO = shO.Cells(Rows.Count, i).End(xlUp).Row     'last row of the found orig header column
        lastRowC = shC.Cells(Rows.Count, j + 1).End(xlUp).Row 'last row of toCopy sheet header column
        arrTransf = shO.Range(shO.Cells(2, i), shO.Cells(lastRowO, i)).Value
        Set copyCell = shC.Range(shC.Range("A1"), shC.Cells(1, lastColO)).Find(arrC(j))
        If copyCell Is Nothing Then MsgBox "There is not a column named """ & _
                                        arrC(j) & """ in the page to Copy.": Exit Sub
        copyCell.Offset(1, 0).Resize(UBound(arrTransf, 1), UBound(arrTransf, 2)).Value = arrTransf
    End If
Next i
 Next j
End Sub

Answer 1

Try this code, please. It copies columns from the active sheet to shC worksheet, which must be set in the code below:

Sub moveColumnsContent()
 Dim shO As Worksheet, shC As Worksheet, lastRowO As Long, lastRowC As Long
 Dim arrO As Variant, arrC As Variant, lastColO As Long, lastColC As Long
 Dim El As Variant, arrTransf As Variant, strH As String, copyCell As Range
 Dim wbNumb As Variant, wb As Workbook, ws As Worksheet, strWB As String
 Dim WbC As Workbook, sh As Worksheet, strWh As String, shNunb As String

 Dim i As Long, j As Long
 Set shC = ActiveSheet
WbSelection:
 For i = 1 To Workbooks.count
    strWB = strWB & Workbooks(i).Name & " - " & i & vbCrLf
 Next i

 wbNumb = InputBox("Please, write the the right workbook name number to be chosen:" & vbCrLf & _
                vbCrLf & strWB, "Choose the workbook from where to copy columns!", 1)
    If wbNumb = "" Then MsgBox "You did not select anything and code stops!"
            Exit Sub
    If IsNumeric(wbNumb) Then
        On Error Resume Next
          Set WbC = Workbooks(CLng(wbNumb))
          if Err.Number<> 0 Then
             Err.Clear: On Error GoTo 0:Exit Sub
          End If
       On Error GoTo 0
    Else
        MsgBox "Please select the number to the right side of the chosen workbook!": GoTo WbSelection
    End If
WsSelection:
    For i = 1 To WbC.Worksheets.count
        strWh = strWh & WbC.Worksheets(i).Name & " - " & i & vbCrLf
    Next
  shNunb = InputBox("Please, write the the right sheet name number to be chosen:" & vbCrLf & _
          vbCrLf & strWh, "Select the worksheet to be used for copying the columns!", 1)
     If shNunb = "" Then MsgBox "Please select a worksheet number to be selected for copying columns!": _
            GoTo WsSelection
 Set shO = WbC.Worksheets(CLng(shNunb))

 arrC = Split("Code|Ident|Piece", "|")
 lastColO = shO.Cells(1, Cells.Columns.count).End(xlToLeft).Column
 arrO = shO.Range(shO.Cells(1, 1), shO.Cells(1, lastColO)).value
 'Copy the columns:
 For j = 0 To UBound(arrC)
    If arrC(j) = "Piece" Then strH = "Part" Else strH = arrC(j)
    For i = 1 To UBound(arrO, 2)
        If arrO(1, i) = strH Then
            lastRowO = shO.Cells(Rows.count, i).End(xlUp).Row     'last row of the found orig header column
            lastRowC = shC.Cells(Rows.count, j + 1).End(xlUp).Row 'last row of toCopy sheet header column
            arrTransf = shO.Range(shO.Cells(2, i), shO.Cells(lastRowO, i)).value
            Set copyCell = shC.Range(shC.Range("A1"), shC.Cells(1, lastColO)).Find(arrC(j))
            If copyCell Is Nothing Then MsgBox "There is not a column named """ & _
                                            arrC(j) & """ in the page to Copy.": Exit Sub
            copyCell.Offset(1, 0).Resize(UBound(arrTransf, 1), UBound(arrTransf, 2)).value = arrTransf
        End If
    Next i
 Next j
End Sub

If you will need more headers in the sheet to copy, it is enough to add them in "Code|Ident|Piece" string. Now, trying to think how it would be more convenient for you to use it, probably, a better way would be to name the sheet where from the columns will be copied, in a specific way (maybe "MasterSheet") and copy the columns to the active one. Or, iterate between all Workbook sheets and do this process automatically. But, please, try the code as it is and let me know how looks more convenient for you.

Answer 2

If your intention is to extract a three columns set in the fixed order Code|Ident|Part=Piece copying them to the first three target columns A:C, you may try the following Rearrange procedure executing these steps:

• [0-1] get source data
• [2 ] rearrange columns of source data in a given order by a one-liner instead of copying separate columns arrays each time
• [3 ] write (rearranged) data to target sheet

Sub Rearrange(src As Worksheet, tgt As Worksheet)
'Purpose: extract and rearrange data array columns
'Author:  https://stackoverflow.com/users/6460297/t-m
With src
    '[0] get last row of source data in column A:A (Ident)
    Dim lastRow As Long: lastRow = .Range("A" & .Rows.Count).End(xlUp).Row

    '[1] assign data to (1-based) 2-dim variant datafield array
    Dim data: data = .Range("A2:G" & lastRow)

    '[2] rearrange columns
    '    where Array(3,1,4) gets the 3rd, 1st and 4th column only
    '    (and Evaluate("ROW(1:nnn)") gets the entire row set)
    data = Application.Index(data, Evaluate("ROW(1:" & (lastRow - 1) & ")"), Array(3, 1, 4))
End With

'[3] write (rearranged) data to target sheet
tgt.Range("A2").Resize(UBound(data), 3) = data
End Sub

If, however you are confronted with a variable target column structure you might play around with Moving columns based on header name and change it to your needs :-)

Answer 3

This should work, you only need to tweak the target sheet and, if it were the case, add more cases where origin/target have different column names:

Option Explicit
Sub Main()

    Dim arrOrigin As Variant: arrOrigin = GetArrayFromSheet
    Dim OriginHeaders As New Dictionary: Set OriginHeaders = GetOriginHeaders(arrOrigin)

    With ThisWorkbook.Sheets("Your target sheet name") 'change this name
        Dim arrTarget As Variant: ReDim arrTarget(1 To UBound(arrOrigin), _
                                                    1 To .UsedRange.Columns.Count)
        'Last row on column 1 (or column A)
        Dim LastRow As Long: LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    End With
    Dim TargetHeaders As New Dictionary: Set TargetHeaders = GetTargetHeaders(arrTarget)

    Dim i As Long
    Dim Key As Variant
    Dim OriginColumn As Long, TargetColumn As Long
    Dim x As Long: x = 1
    For i = 2 To UBound(arrOrigin)
        For Each Key In TargetHeaders.Keys
            OriginColumn = OriginHeaders(Split(TargetHeaders(Key), "\")(0))
            TargetColumn = Split(TargetHeaders(Key), "\")(1)
            arrTarget(x, TargetColumn) = arrOrigin(i, OriginColumn)
        Next Key
    Next i

    ThisWorkbook.Sheets("Your target sheet name").Range("A" & LastRow).Resize(UBound(arrTarget), UBound(arrTarget, 2)).Value = arrTarget

End Sub
Private Function GetArrayFromSheet() As Variant

    Dim wb As Workbook: Set wb = FilePicker
    Dim ws As Worksheet
    For Each ws In wb.Sheets
        If ws.Name Like "* Annex 1" Then
            GetArrayFromSheet = ws.UsedRange.Value
            wb.Close False
            Exit Function
        End If
    Next ws

End Function
Private Function FilePicker() As Workbook

    With Application.FileDialog(msoFileDialogOpen)
        .Filters.Clear
        .Filters.Add "Excel 2007-13", "*.xlsx; *.xlsm; *.xlsa"
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count > 0 Then
            Set FilePicker = Workbooks.Open(.SelectedItems(1))
        Else
            MsgBox "No file was selected, the procedure will end"
            End
        End If
    End With

End Function
Private Function GetOriginHeaders(arr As Variant) As Dictionary

    Set GetOriginHeaders = New Dictionary
    Dim i As Long
    For i = 1 To UBound(arr, 2)
        GetOriginHeaders.Add arr(1, i), i
    Next i

End Function
Private Function GetTargetHeaders(arr As Variant) As Dictionary

    Set GetOriginHeaders = New Dictionary
    Dim i As Long
    Dim MyHeader As String
    For i = 1 To UBound(arr, 2)
        MyHeader = arr(1, i)
        Select Case MyHeader
            Case "Piece"
                MyHeader = "Part"
            '..More cases for different names
        End Select
        TargetHeaders.Add arr(1, i), MyHeader & "\" & i
    Next i

End Function