Link to home
Start Free TrialLog in
Avatar of mikes6058

asked on

move and copy worksheet - Macro keeps crashing.....

Hi all,

Below is a macro which will move and copy a worksheet from one workbook to another. It will will also copy some of the information from the worksheet to another worksheet in the destination workbook.

However when I run the code the macro is causing excel to crash. I do not receive an error dialogue or message which would indicate it could be an issue with the processing speed???

The data on the sheet has been retrieved from pivot tables etc. using index match and vlookups...

To add when i try to move and copy the worksheet manually I get the same result when my machine crashes.

Could anyone suggest a way to fix this.

Sub ImportForm()
    Dim wbLog As Workbook
    Dim MainSht As Worksheet, LogSht As Worksheet, CopySht As Worksheet
    Dim rData As Range
    Dim NewRw As Long
    Dim sFil As String, sTitle As String, sWb As String
    Dim iFilterIndex As Integer

    Set MainSht = ActiveSheet
    ' Set up list of file filters
    sFil = "Excel Files (*.xl*),*.xl*"
    ' Display *.xls by default
    iFilterIndex = 1
    ' Set the dialog box caption
    sTitle = "Select  File to Zip"
    ' Get the filename
    With Application
        sWb = .GetOpenFilename(sFil, iFilterIndex, sTitle)
        Set wbLog = Workbooks.Open(sWb)
        '        On Error GoTo err_handler
        .ScreenUpdating = False
        .DisplayAlerts = False

        Set LogSht = Worksheets("Member.Meetings.Log")

        MainSht.Copy After:=wbLog.Sheets(wbLog.Sheets.Count)
        ActiveSheet.Name = ActiveSheet.Range("B4").Value
        Set CopySht = ActiveSheet

        Set rData = LogSht.Range("A1").CurrentRegion.Offset(1)
        NewRw = rData.Rows.Count + 1

        NewRw = rData.Rows.Count
        rData.Cells(NewRw, 1).Select
        ActiveSheet.Paste Link:=True
        'company name
        rData.Cells(NewRw, 2).Select
        ActiveSheet.Paste Link:=True
        'date of meeting
        rData.Cells(NewRw, 3).Select
        ActiveSheet.Paste Link:=True
        rData.Cells(NewRw, 4).Select
        ActiveSheet.Paste Link:=True
        'add link
        rData.Cells(NewRw, 5).Select
        LogSht.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
                              "'" & CopySht.Name & "'!A1", TextToDisplay:=CopySht.Name


        .ScreenUpdating = True
        .CutCopyMode = False
        .DisplayAlerts = True
    End With

    Exit Sub
    MsgBox "No file selected", vbCritical
    Resume clean_up
End Sub

Open in new window

Avatar of [ fanpages ]
[ fanpages ]

Link to home
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of [ fanpages ]
[ fanpages ]

Thanks for closing the question based on my suggestion above.

Was this successful?