Avatar of mikes6058
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

        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

Open in new window

Microsoft Excel

Avatar of undefined
Last Comment
[ fanpages ]

8/22/2022 - Mon
ASKER CERTIFIED SOLUTION
[ fanpages ]

THIS SOLUTION ONLY AVAILABLE TO MEMBERS.
View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
See Pricing Options
Start Free Trial
GET A PERSONALIZED SOLUTION
Ask your own question & get feedback from real experts
Find out why thousands trust the EE community with their toughest problems.
[ fanpages ]

Thanks for closing the question based on my suggestion above.

Was this successful?
This is the best money I have ever spent. I cannot not tell you how many times these folks have saved my bacon. I learn so much from the contributors.
rwheeler23