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.Nameclean_up: .ScreenUpdating = True .CutCopyMode = False .DisplayAlerts = True End With Exit Suberr_handler: MsgBox "No file selected", vbCritical Resume clean_upEnd Sub
Was this successful?