Ho can I improve the time taken to paste the data?

[Mr Denove]

Sub Achievements()
    Dim FName As Variant
    FName = Application.GetOpenFileName(FileFilter:="Excel Files (*.xlsm), *.xlsm", Title:="Select File To Be Opened")
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    Workbooks.Open FName, ReadOnly:=True
    
    SG_MoveColumns ("Achievements ")
    ThisWorkbook.Activate
    Application.Calculation = xlCalculationAutomatic
    MsgBox "Achievements Done. Check Columns."

    Worksheets("Import Macros").Range("F17").Value = "Done"
    
End Sub

Sub SG_MoveColumns(sSheetname As String)

    Dim src As Worksheet
    Dim srcLastRow As Double
    Dim srcLastCol As Double
    Dim tgt As Worksheet
    Dim tgtLastRow As Double
    Dim dest As Range
    Dim i As Long
    Dim x As Long
    Dim sColLetter As String
    Dim stgtColLetter As String
    Dim bFoundCol As Boolean
    

    ' Switch screen updating back off
    Application.ScreenUpdating = False

    ' Create objects to use
    Set src = Worksheets(sSheetname)  ' use sheet name passed in to the
    srcLastRow = src.Cells(Rows.Count, 1).End(xlUp).Row
    srcLastCol = src.Cells(1, Columns.Count).End(xlToLeft).Column
    
    Set tgt = Workbooks("Template - Data.xlsm").Worksheets("Achievements")
    tgtLastRow = tgt.Cells(Rows.Count, 2).End(xlUp).Row

    ' Selects the columns to be copied
    
 myColumns = Array("Assignment id", "Programme", "Trainee type", "Regional area", "Age at start", "Awarding body", _
            "Creditor", "Provider", "Employed status", "ESF dos. number", "ESF dos. desc", "Eligibility code", _
            "Eligibility desc", "Esol", "Expected end date", "First time entrant", "Framework id", "MA framework desc", _
            "SDS funding org desc", "Funding type", "GG funding", "Input date", "Input leaving date", "Modern apprenticeship", _
            "Leaving code", "Leaving code desc", "CLP Outcome desc", "Leaving date", "SDS local area", "SDS local area desc", _
            "Soc code", "Soc code desc", "Soc2000", "Soc2000 desc", "Start date", "Status indicator", "Training category", _
            "VQ level", "VQ reference", "VQ title", "VQ level held", "Unemployed duration", "Unempdur description", _
            "Currjob duration", "Currjob dur desc", "Person id", "First names", "Last name", "NI number", "Date of birth", _
            "Gender", "Exclude from Survey", "Disability", "Ethnicity", "Home phone no", "Works phone no", "Mobile phone no", _
            "Email Address", "Asylum seeker", "SQA cand. no", "Completed", "Employed status at end", "Exp attainment", "Prog type", _
            "Program type desc", "CL Learn.Prog", "MA Curr. Emp. ", "MA Curr. role", "MA Prev. Emp. ", "Referred by code", "Soc2000 at end", _
            "Soc2000 at end desc", "Contract title", "Person postcode in", "Person postcode out", "Person address1", "Person address2", _
            "Person address3", "Person address4", "Person posttown", "Trainee district code", "Trainee district desc", "Max placement id", _
            "Company id", "Company name", "Company address1", "Company address2", "Company address3", "Company address4", "Company town", _
            "Company postcode in", "Company postcode out", "Company sic03 code", "Company employee size band03", "Sic03 code", "Sic03 desc", _
            "Sic03 level 1 code", "Sic03 level 1 desc", "Company district code", "Company district desc", "Achievement desc", "Reporting Area", "SIA", "Learning Provider on Contract", _
            "Procurement Group", "Updated Programme", "Programme Type", "Age Band", "Advanced bookings", "Updated Employer")

                
    ' Search the source worksheet to find the columns that the required field are in
    For i = 0 To UBound(myColumns)
    On Error Resume Next
            
            ' search the column headers - assume that held in row 1
            '   set the flag to NOT FOUND
            bFoundCol = False
            
            For x = 1 To srcLastCol
            On Error Resume Next
            
                If Trim(UCase(myColumns(i))) = Trim(UCase(src.Cells(1, x).Text)) Then
                    bfound = True
                    
                    ' convert the column number in to a column letter
                    sColLetter = Col_Letter(x)
                    
                    ' convert the array to the target column letter
                    stgtColLetter = Col_Letter(i + 1)
                    
                    ' copy of the column data
                    'Range(sColLetter is the column reference & "2" is the row of that column i.e. 2 omits the header
                    src.Range(sColLetter & "2:" & sColLetter & srcLastRow).Range (stgtColLetter & tgtLastRow + 1)
                    

                    Exit For
                End If
            
            Next x
    Next i
        
    'Tidy-up created objects
    Set src = Nothing
    Set tgt = Nothing
    
    ' Switch screen updating back on
    Application.ScreenUpdating = True

End Sub

Function Col_Letter(lngCol As Long) As String
    Dim vArr
    
    ' calculate the letter linked to the column
    vArr = Split(Cells(1, lngCol).Address(True, False), "$")
    
    ' return the letter
    Col_Letter = vArr(0)
End Function

The above code compiles fine, apart from the delay in opening the source datasheet.

One other major time constraint is the time taken to copy the data listed in the array into the destination file.
Is there anyway to improve this?
Thanks in advance.

 

[Andrew Poulsom]

Rather than looping you can use Application.Match or the Find method to return the column number. And if you use the Cells property instead of the Range property you won't need to convert the column number to a letter.

By the way I don't see any copying in this statement:

src.Range(sColLetter & "2:" & sColLetter & srcLastRow).Range (stgtColLetter & tgtLastRow + 1)