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

        CopySht.Range("B10").Copy
        LogSht.Select
        'manager
        NewRw = rData.Rows.Count
        rData.Cells(NewRw, 1).Select
        ActiveSheet.Paste Link:=True
        'company name
        CopySht.Range("C2").Copy
        rData.Cells(NewRw, 2).Select
        ActiveSheet.Paste Link:=True
        'date of meeting
        CopySht.Range("E6").Copy
        rData.Cells(NewRw, 3).Select
        ActiveSheet.Paste Link:=True
        CopySht.Range("D4").Copy
        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

   

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

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

Select all Open in new window