Copy columns between worksheets using arrays

Question

I want to copy some columns in the active sheet to a workbook which is opened during run time. The attached code is working well, EXCEPT that I want to READ the column headers in the source sheet rather than have them be hard-defined, because they might not be always the same. The lines I want to transfer start at row 2 on the source and should be pasted also on row 2 on the paste file. Thank you!

Here is the code:

Option Explicit

Sub CopyPvtToTemplate()
' Copies the columns in the Source file and pastes them into template
' The Source file is the Active Sheet

Const LastRowColumnS As Long = 2
Const FirstRowS = 2
Const FirstRowP = 2

Dim HeadSource As Variant
Dim HeadPaste As Variant
Dim LastRow As Long

HeadSource = Array("Header Column I", "Header Column E", "Header Column F",  "Header Column G", "Header Column H", "Header Column B", "Header Column J")

HeadPaste = Array("Header Column A", "Header Column B", "Header Column C",   "Header Column D", "Header Column E", "Header Column F", "Header Column H")

Dim rng As Range
Dim PasteFile As Variant
Dim wsS As Worksheet
Dim wsP As Worksheet
Dim CurColS As Long
Dim CurColP As Long
Dim NumberOfRows As Long
Dim Count As Long
Dim i As Long

' Define Source Worksheet and Last Row in Source file
Set wsS = ActiveSheet

With ActiveSheet
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
End With

' Open Paste file
Set PasteFile = Workbooks.Open("C:\Users\ etc.xlsx")

' Define Source Worksheet
Set wsP = PasteFile.Worksheets(2)

' Define last cell with data in Last Row Column of Source Sheet
Set rng = wsS.Columns(LastRowColumnS).Find(what:="*", LookIn:=xlFormulas, Searchdirection:=xlPrevious)

If rng Is Nothing Then
MsgBox "No data in column"
Exit Sub
End If

NumberOfRows = rng.Row - FirstRowS + 1

For i = 0 To UBound(HeadSource)
' Define column of current header in Source Sheet
Set rng = wsS.Cells.Find(what:=HeadSource(i), after:=wsS.Cells(wsS.Rows.Count, wsS.Columns.Count), _
LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByRows)
If Not rng Is Nothing Then
CurColS = rng.Column
' Define column of Current Header in Paste sheet
Set rng = wsP.Cells.Find(what:=HeadPaste(i), after:=wsP.Cells(wsP.Rows.Count, wsP.Columns.Count), _
LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByRows)
If Not rng Is Nothing Then
CurColP = rng.Column
' Write data from Source Sheet to Paste Sheet
wsP.Cells(FirstRowP, CurColP).Resize(NumberOfRows).Value = _
wsS.Cells(FirstRowS, CurColS).Resize(NumberOfRows).Value
' Count the transfer
Count = Count + 1
End If
End If
Next i

MsgBox "Transferred data from '" & Count & "'Columns."

End Sub

Admin · Answer

I think you're setting yourself up for potential errors by taking this approach - i.e. if you don't type the exact text of the column headings / number of headings within your code etc. Also, using ActiveSheet can be fraught with danger. Having said that, the code below should give you what you want - just change the names to the actual headers, as well as the target file. Let me know how you go.

EDIT

Code edited following clarification from OP.

Option Explicit
Sub CopyPvtToTemplate()
On Error GoTo GetOut
Application.EnableEvents = False

Dim LastRow As Long
Dim wb As Workbook, wsS As Worksheet, wsP As Worksheet
Dim sArray, pArray, i As Integer, j As Integer
Dim Scol As Integer, Pcol As Integer

Set wsS = ActiveSheet
Set wb = Workbooks.Open(ThisWorkbook.Path & "\etc.xlsx")    '<~~ change to suit
Set wsP = wb.Sheets(2)

LastRow = wsS.Cells(Rows.Count, 2).End(xlUp).Row

sArray = Array(9, 5, 6, 7, 8, 2, 10)
pArray = Array(1, 2, 3, 4, 5, 6, 8)

For i = 0 To UBound(sArray)
    Scol = sArray(i)
        For j = 0 To UBound(pArray)
            Pcol = pArray(i)
            wsS.Range(wsS.Cells(2, Scol), wsS.Cells(LastRow, Scol)).Copy wsP.Cells(2, Pcol)
        Next j
Next i

MsgBox "Transferred data from " & i & " columns"

Continue:
    Application.EnableEvents = True
    Exit Sub
GetOut:
    MsgBox Err.Description
    Resume Continue

End Sub

Copy columns between worksheets using arrays

1 Answers