Slow and Funky Screen Behavior RRS feed

  • Question

  • Just wading  back into VBA coding after a several year hiatus. All my previous experience was in Access. Now I'm working with Excel. I wrote the following macro. It consistently achieves the intended result BUT two problems: 1) It runs slow, particularly during execution of the with statement and b) if I run it from the VBA edtor it works well but, if I run it from a command button it produces a grey screen and "not responding" indication until it completes. Any suggestions appreciated. Thank you!

    [Purpose: Open a file, copy a specified range and paste the copied cells into the first blank row in the destination worksheet (in a separate workbook) and copy the name of the source file, including path, into corresponding rows.

    Sub NewManifestUpdater()

        Dim numSourceRowstoCopy As Integer
        Dim NextRow As Long
        Dim NextRow2 As Long
        Dim WkbName As Object
    'This section of the code opens the specified file and holds the opened file name in memory

        FiletoOpen = Application.GetOpenFileName _
        (Title:="Please choose a file")
    Application.ScreenUpdating = False

        If FiletoOpen = False Then
            MsgBox "No file specified."
            Exit Sub
            filename1 = FiletoOpen
            Workbooks.Open filename1
        End If
        Application.Cursor = xlWait

    'Select Range of data to copy from source file

        numSourceRowstoCopy = Range("A2").End(xlDown).Row
        Range("a2:i" & numSourceRowstoCopy).Select
    'Activate the worksheet with this code /Main database

        NextRow = Range("b100000").End(xlUp).Row + 1
        Range("b" & NextRow).Select
        ActiveSheet.Paste Destination:=Worksheets("Receiving").Range("b" & NextRow)

    'Determine first empty row in column A

        NextRow = Range("a200000").End(xlUp).Row + 1
        'Range("A" & NextRow).Value = filename1
        'Range("A" & NextRow).Select
        NextRow2 = Range("b500000").End(xlUp).Row
        'ActiveSheet.Paste Destination:=Worksheets("Receiving").Range("a" & NextRow & ":" & "a" & NextRow2)
        With Range("a" & NextRow & ":" & "a" & NextRow2)
            .Value = filename1
        End With
        Application.CutCopyMode = False
        For Each WkbkName In Application.Workbooks()
            If WkbkName.Name <> ThisWorkbook.Name Then WkbkName.Close (False)
        Application.ScreenUpdating = True
        Application.Cursor = xlNorthwestArrow
        MsgBox "Process Complete"

    End Sub

    Thursday, May 16, 2013 7:36 PM