Copy/Paste columns - excel

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