Copy Destination Speed Issue Query

akjohno

New Member
Joined
Mar 27, 2018
Messages
27
Office Version
  1. 365
Platform
  1. Windows
Greetings all, the code below seems to work fine on smaller data files, but on larger data files it gives varying random results. It appears (at least to my small brain) to me that maybe the Macro hasn't finished copying the values of the original location over to the new location before it moves onto the next line of code? Just wondering if this is a correct assumption or am I completely on the wrong path? I can't get the code to fault when doing an F8 Step Into, hence my assumptions. I have put my entire code below and commented where I think the errors are happening. The result when it errors is that not all of column A & B on sheet "wsname" are populated. Sometimes only the first couple of thousand are populated, sometimes up to fifty thousand are populated. Data rows up to about 100 000 rows. The macro converts space delimited .dat files to .csv files for survey co-ordinates.

VBA Code:
Sub Convert()

' Conversion Macro

On Error GoTo errorhandler
'Variable Declarations
    Dim NumShots As Long
    Dim wbname As String, wsname As String, fullpath As String, sp As String, coords2 As String
    Dim name1 As String, name2 As String, pastearea As String, pastearea2 As String, coords As String
    Dim wsnew As Worksheet
    Dim a As Variant
    Dim i As Long
    'Stop screen from flickering while windows change
    Application.ScreenUpdating = False
   '   Asks you where the file you want to convert is located
    With Application.FileDialog(msoFileDialogFilePicker)    'Start of picking your file
            .AllowMultiSelect = False               'Allows you to only open one file
            .Filters.Add "Text Files", "*.dat", 1   'Looks only for .dat files
            .Show                                   'Opens the File Dialog Box
        fullpath = .SelectedItems.Item(1)           'Assigns the location of the file to the variable "fullpath"
    End With                                        'Exits the search function
    If Right(fullpath, 3) <> "dat" Then             'Error trap in case you don't select a dat file
        MsgBox ("You need to select a .dat file!")  'Message box to advise user that a dat file wasn't selected
        GoTo errorhandler                           'Sends you to the error trap which will close code down
    End If                                          'End of picking your file
    'Assigning variable fullpath to full address of file and imports file data into the dat file correctly delimited
    Workbooks.OpenText Filename:= _
        fullpath, _
        Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
        xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, _
        Comma:=False, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), _
        Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True
    wbname = ActiveWorkbook.Name                    'Assigns variable wbname to the name of this workbook
    wsname = ActiveSheet.Name                       'Assigns variable wsname the name of this worksheet
    NumShots = Application.WorksheetFunction.CountA(Range("A:A"))   'Counts the number of survey points in the file
    Set wsnew = Sheets.Add(After:=Sheets(wsname))   'Adds a new worksheet


   '****This is where I think my errors are happening--- from here****

    'Copies the co-ordinate converter section of the main file to this dat file
    Workbooks("CATAN Converter.xlsm").Sheets("Sheet2").UsedRange.Copy Destination:=Workbooks(wbname).Worksheets("Sheet1").Range("A1")  'Copies conversion data over
    Windows(wbname).Activate                        'Goes back and selects our new dat workbook
    pastearea = "G5:AF" & NumShots + 3              'Assigns the variable pastearea the value of the cells we need to paste to
    Range("G4:AF4").Copy Destination:=ActiveSheet.Range(pastearea)  'Copies the formulas from cells G4 to AF4
    ActiveWorkbook.Worksheets(1).Activate           'Selects the first worksheet in the workbook
    pastearea2 = "A1:B" & NumShots                  'Assigns the variable pastearea2 the value of all the cells we need to copy
    'Sheets("Sheet1").Range("D4:E" & NumShots + 3).Value = Range(pastearea2).Value    'Copies co-ordinates to conversion sheet
    Sheets(wsname).Range(pastearea2).Copy Destination:=Worksheets("Sheet1").Range("D4")
    Sheets("Sheet1").Select                         'Selects our co-ordinate transformation sheet1
    Range("A1").Select                              'Selects cell A1 to prevent any confusion
    'Copy converted co-ordinates back to final sheet
    coords = "AD4:AE" & NumShots + 3                'Assigns the variable coords the value of all the converted co-ordinate cells we need to copy
    With Sheets("Sheet1").Range(coords)
        Worksheets(wsname).Range(pastearea2).Value = .Value
    End With

   '****To here****


    Range("A1").Select                              'Selects cell A1 to prevent any confusion
    Sheets("Sheet1").Select                         'Selects Sheet1
    Application.DisplayAlerts = False               'Turns off Display of box asking to accept sheet deletion
    ActiveWindow.SelectedSheets.Delete              'Deletes Sheet1
    Application.DisplayAlerts = True                'Turns display alerts back on
    ' Converts Feature Codes to CATAN usable format
    With Range("D1", Range("D" & Rows.Count).End(xlUp))
        a = .Value
        For i = 1 To UBound(a)
            Select Case a(i, 1)
                Case 700: a(i, 1) = vbNullString
                Case 400: a(i, 1) = "%po"
                Case Else: a(i, 1) = "%sp"
            End Select
        Next i
        .Value = a
    End With
    'Saving of new file for CATAN
    name1 = InStrRev(fullpath, ".")                 'Counts the number of characters in front of the . in the file name
    name2 = Left(fullpath, name1)                   'Grabs the name of the file using the character count above
    'Uses the filename from above and puts csv after it so that it saves to the same location as a different file type
    ActiveWorkbook.SaveAs Filename:= _
    name2 & "csv", FileFormat:=xlCSV, CreateBackup:=False
    MsgBox "Created " & name2 & "csv for use in CATAN." & vbNewLine & "File location same as original file location"  'Advises user the file location
    ActiveWorkbook.Close                            'Closes this file
    Workbooks("CATAN Converter.xlsm").Close savechanges:=False  'Closes the Master workbook
Exit Sub
errorhandler:
    MsgBox "An Error has occurred." & vbNewLine & "Please re-run."
    Exit Sub
End Sub
 
Last edited:

Some videos you may like

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.

ExcelGzh

Board Regular
Joined
Mar 29, 2020
Messages
59
Office Version
  1. 365
Platform
  1. Windows
My first suggestion is that there is some kind of an event or automatic calculation getting in the way. Whenever I run large data transfers I run a couple of routines to turn off things that might interfere with the transfer and then when it's done turn them back on again.

You may notice the comment in EventsDisable in the ErrorRoutine section about turning everything back on if there is an error. You will need to do this in your error handling section as well.

VBA Code:
Sub EventsDisable()
  On Error GoTo ErrorRoutine
  Application.Calculation = xlManual
  Application.DisplayStatusBar = True 'Always make sure the Status Bar is visible
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  Application.StatusBar = ""
ExitRoutine:
  Exit Sub
ErrorRoutine:
  EventsEnable 'Always run EventsEnable here so that when there is an error all the things that were turned off get turned back on first
  ErrorMsgNum = Err.Number
  ErrorMsgDesc = Err.Description
  MsgBox ErrorMsgNum & " " & ErrorMsgDesc & " in module EventsDisable"
  Resume ExitRoutine
End Sub 'EventsDisable

Sub EventsEnable()
  On Error GoTo ErrorRoutine
  Application.Calculation = xlAutomatic
  Application.DisplayAlerts = True
  Application.DisplayStatusBar = True
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  Application.StatusBar = ""
ExitRoutine:
  Exit Sub
ErrorRoutine:
  ErrorMsgNum = Err.Number
  ErrorMsgDesc = Err.Description
  MsgBox ErrorMsgNum & " " & ErrorMsgDesc & " in module EventsEnable"
  Resume ExitRoutine
End Sub 'EventsEnable
 

Watch MrExcel Video

Forum statistics

Threads
1,113,978
Messages
5,545,302
Members
410,675
Latest member
DLongmountain
Top