Vba copy and paste in new excel make new excel freeze

[Vagelisr]

Hi to all.
I'm facing a strange issue.
I have an excel and i use the code in the bottom to create some other excel files using copy and paste. (The first copy is for the headers and the second is for the data)
The problem is: If i open any of the file i had create excel freeze and i had to make end process to close the excel.
Can anyone help me with this problem??

Thanks and regards.
PS1:If i make copy paste only the headers the new excel's close without problem
PS2:If i make copy and paste special the data the new excel's close without problem

This is the code i use.

Sub Split()
    Dim lRow As Integer
    Dim lCol As Integer
    Dim First_Range_Line As Integer
    Dim Last_Range_Line As Integer
    Dim Compare_Data As String
    Dim New_Excel_Column_Name1 As String
    Dim New_Excel_Column_Name2 As String
    Dim New_Excel_Name As String
    Dim PathForSave As String
    Dim Change_Column As String
    Dim Current_Workbook_Name As String
    Dim New_Workbook_Name As String
    Dim SumiRow As Integer
    
    Current_Workbook_Name = ActiveWorkbook.Name
    
    First_Range_Line = Worksheets("Parm").Cells(2, 2).Value + 1 '4
    New_Excel_Column_Name1 = Worksheets("Parm").Cells(5, 2).Value 'A
    New_Excel_Column_Name2 = Worksheets("Parm").Cells(5, 3).Value 'B
    Change_Column = Worksheets("Parm").Cells(3, 2).Value 'A
    New_Workbook_Name = Worksheets("Parm").Cells(4, 2).Value 'Data
    
    Worksheets("DataAll").Activate
    PathForSave = Application.ActiveWorkbook.Path & "\"
    
    Compare_Data = ActiveSheet.Cells(First_Range_Line, Change_Column).Value
    lRow = ActiveSheet.Range(Change_Column & Rows.Count).End(xlUp).Row 'Last Row
    lCol = ActiveSheet.Cells(2, Columns.Count).End(xlToLeft).Column 'Last Column
    For i = 5 To lRow + 1
        If ActiveSheet.Cells(i, Change_Column).Value <> Compare_Data Then
            New_Excel_Name = ActiveSheet.Cells(i - 1, New_Excel_Column_Name1).Value & "-" & ActiveSheet.Cells(i - 1, New_Excel_Column_Name2).Value
            Copy_Header
            ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(3, lCol)).Select
            Selection.Copy
            
            'Create New Excel with Name
            Workbooks.Add
            ActiveSheet.Name = New_Workbook_Name
            Paste_Header
            ActiveSheet.Paste
            ActiveWorkbook.SaveAs PathForSave & New_Excel_Name
            
            Workbooks(Current_Workbook_Name).Activate

            Worksheets("DataAll").Activate
            Last_Range_Line = i - 1
            'Copy_Data
            ActiveSheet.Range(ActiveSheet.Cells(First_Range_Line, 1), ActiveSheet.Cells(Last_Range_Line, lCol)).Select
            Selection.Copy
            
            'Paste_Data
            Workbooks(New_Excel_Name & ".xls").Activate '------------------
            Worksheets(New_Workbook_Name).Activate
            ActiveSheet.Cells(4, 1).Select
            ActiveSheet.Paste
            
            'Save & Close New Excel
            SumiRow = ActiveSheet.Range(Change_Column & Rows.Count).End(xlUp).Row 'Last Row for Sum
            ActiveSheet.Cells(2, 62).Formula = "=SUM(BJ4:BJ" & SumiRow & ")"
            
            Application.DisplayAlerts = False
            ActiveWorkbook.Close SaveChanges:=True
            Application.DisplayAlerts = True
         
            Compare_Data = ActiveSheet.Cells(i, Change_Column).Value
            First_Range_Line = i
         
        End If
    Next i
End Sub

 

[Yongle]

Which version of Excel are you using?
(New_Excel_Name & ".xls suggests that you are using Excel 2003)



I do not know why your code is freezing Excel
Selecting every cell and sheet and workbook is NOT required and it slows your code down
Your code is currently very reliant on ActiveWorkbook and ActiveSheet - which makes it tricky when you want to amend the code
Get in the habit of using variables

I have looked at a section of your code and rewritten it
-you need to check that the references are correct etc

Instead of this

            Workbooks(Current_Workbook_Name).[COLOR=#ff0000]Activate[/COLOR]
            Worksheets("DataAll").[COLOR=#ff0000]Activate[/COLOR]
            Last_Range_Line = i - 1
            'Copy_Data
            [COLOR=#008080]ActiveSheet[/COLOR].Range(A[COLOR=#008080]ctiveSheet[/COLOR].Cells(First_Range_Line, 1), [COLOR=#008080]ActiveSheet[/COLOR].Cells(Last_Range_Line, lCol)).[COLOR=#ff0000]Select[/COLOR]
            Selection.Copy
            
            'Paste_Data
            Workbooks(New_Excel_Name & ".xls").[COLOR=#ff0000]Activate [/COLOR]'------------------
            Worksheets(New_Workbook_Name).[COLOR=#ff0000]Activate[/COLOR]
            [COLOR=#008080]ActiveSheet[/COLOR].Cells(4, 1).[COLOR=#ff0000]Select[/COLOR]
            [COLOR=#008080]ActiveSheet[/COLOR].Paste

            'Save & Close New Excel
            SumiRow = ActiveSheet.Range(Change_Column & Rows.Count).End(xlUp).Row 'Last Row for Sum
            [COLOR=#008080]ActiveSheet[/COLOR].Cells(2, 62).Formula = "=SUM(BJ4:BJ" & SumiRow & ")"
            
            Application.DisplayAlerts = False
            [COLOR=#008080]ActiveWorkbook[/COLOR].Close SaveChanges:=True
            Application.DisplayAlerts = True
         
            Compare_Data = ActiveSheet.Cells(i, Change_Column).Value
            First_Range_Line = i

Try something like this (not tested)

            Dim wb As Workbook, ws As Worksheet, wbNew As Workbook, wsNew As Worksheet, rCopy As Range, rPaste As Range
            
            Set wb = Workbooks(Current_Workbook_Name)
            Set ws = wb.Worksheets("DataAll")
            Last_Range_Line = i - 1
            
            Set wbNew = Workbooks(New_Excel_Name & ".xls")
            Set wsNew = wbNew.Worksheets(New_Workbook_Name)
            Set rCopy = ws.Range(ws.Cells(First_Range_Line, 1), ws.Cells(Last_Range_Line, lCol))
            Set rPaste = wsNew.Cells(4, 1)
           '[I][COLOR=#006400]copy & paste[/COLOR][/I]
            rCopy.Copy Destination:=rPaste
            
            SumiRow = wsNew.Range(Change_Column & Rows.Count).End(xlUp).Row 'Last Row for Sum
            wsNew.Cells(2, 62).Formula = "=SUM(BJ4:BJ" & SumiRow & ")"
            
            Application.DisplayAlerts = False
            wbNew.Close SaveChanges:=True
            Application.DisplayAlerts = True
         
            Compare_Data = ws.Cells(i, Change_Column).Value
            First_Range_Line = i

 

[Vagelisr]

Finally the code hasn't any error.
The code is part from 2 diff subroutines. The first one is for merge and the second one is for split.
We try this code in another excel and work like a charm. So the problem is with the merge subroutine.
Thank you VERY MUCH for your time and the code Yongle

 

[Yongle]

Thanks for the feedback