Need help with slow code

[furt0414]

Hi All,

I wrote a macro today that creates individual files for our regional managers from a consolidated file of all regionals. The code works exactly as intended, however it's slower than I can handle. Does anyone have tips for things I can remove or alter to speed things up? Any help is appreciated.

Sub RegionalView()


Dim r As Range
Dim LastColumn As Integer
Dim LastRow As Integer
Dim LastRow2 As Integer
Dim LC As Integer
Dim MC As Integer
Dim NC As Integer
Dim TopRow As Integer
Dim BottomRow As Integer
Dim q As Worksheet
Dim Day As String
Dim Month As String
Dim Year As String
Dim DataWorkbook As Workbook
Dim IndividualWorkbook As Workbook
Dim RM As String
Dim H As Long
Dim Section1 As Long
Dim Section2 As Long
Dim Section3 As Long


Application.ScreenUpdating = False
Application.DisplayAlerts = False


Set DataWorkbook = ActiveWorkbook
Day = Sheets("Macro").Range("D12")
Month = Sheets("Macro").Range("D13")
Year = Sheets("Macro").Range("D14")


'Sort the Raw Data
Sheet6.Select
ActiveSheet.Name = "Eform report 2"
Set r = ActiveSheet.UsedRange.Resize(1)
LastColumn = ActiveSheet.Range("ZZ1").End(xlToLeft).Column
LastRow = ActiveSheet.Range("A100000").End(xlUp).Row
ActiveSheet.Range("A1", Cells(LastRow, LastColumn)).Sort Key1:=ActiveSheet.Columns("G"), Order1:=xlAscending, Key2:=ActiveSheet.Columns("I"), Order2:=xlAscending, Header:=xlYes


'Create a sheet, move to new workbook, save as name


Set r = ActiveSheet.UsedRange.Resize(1)
LastRow = ActiveSheet.Range("A100000").End(xlUp).Row + 1
LC = 7
Range("A1").Select
Selection.End(xlToRight).Select
MC = ActiveCell.Column
TopRow = 2
For I = 3 To LastRow
    If Cells(I, LC) <> Cells(I, LC).Offset(-1, 0) Then
        BottomRow = I - 1
        'TopRow = i + 1
        Sheets.Add
        'ActiveSheet.Name = Sheets("Data").Cells(I - 1, LC + 3)
        Set q = ActiveSheet
        q.Name = "Eform Report"
        Sheet6.Select
        r.Select
        Selection.Copy
        q.Select
        Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Sheet6.Select
        Range("A" & TopRow, Cells(BottomRow, MC)).Select
        Selection.Copy
        q.Select
        Range("A2").Select
        ActiveSheet.Paste
        Sheets(Array(2, 3, 4, 5, 6, 8)).Select
        Sheets(Array(2, 3, 4, 5, 6, 8)).Copy
        RM = q.Range("G2")
        ActiveSheet.Range("A1").Select
        Sheets(6).Select
        LastRow2 = ActiveSheet.Range("A100000").End(xlUp).Row + 1
        NC = 3
        For H = LastRow2 To 2 Step -1
            If Cells(H, NC) <> RM Then
                Cells(H, NC).EntireRow.Delete
            End If
        Next H
        Sheets(1).Select
        ActiveSheet.Range("A9").Select
        Section1 = ActiveSheet.Range("A9").End(xlDown).Row
        NC = 7
        For H = Section1 To 10 Step -1
            If Cells(H, NC) <> RM Then
                Cells(H, NC).EntireRow.Delete
            End If
        Next H
        Section2 = ActiveSheet.Range("A100000").End(xlUp).Row
        Section3 = ActiveSheet.Range("L1").End(xlDown).Row + 1
        For H = Section2 To Section3 Step -1
            If Cells(H, NC) <> RM Then
                Cells(H, NC).EntireRow.Delete
            End If
        Next H
        Set IndividualWorkbook = ActiveWorkbook
        SaveFileName = Month & " TJX Eform Tracking Report - " & Day & " - " & RM & ".xlsx"
        ActiveWorkbook.SaveAs Filename:=SaveFileName & sFile, FileFormat:=51
        ActiveSheet.Range("A1").Select
        Sheets("Cover Sheet").Select
        DataWorkbook.Activate
        IndividualWorkbook.Close
        Sheets("Eform Report").Select
        ActiveSheet.Delete
        Sheet3.Select
        TopRow = I
    End If
Next I


Application.ScreenUpdating = True
Application.DisplayAlerts = True


DataWorkbook.Activate


Sheet3.Name = "Eform Report"


End Sub

 

[JTannas]

Hi furt,

My number one rule for speeding up code and improving reliability is: Stay out of the Spreadsheet

I find that the biggest speed and reliability improvements in Excel VBA comes from minimizing traffic between the spreadsheets and the code.

I'd start by eliminating the use of "(Something).Activate", "(Something).Select", and Selection.(Stuff)

For example, where you use:

[COLOR=#574123]Sheet6.Select[/COLOR]
[COLOR=#574123]ActiveSheet.Name = "Eform report 2"[/COLOR]

A faster and more reliable way is to use a direct command:

[COLOR=#574123]Sheet6[/COLOR][COLOR=#574123].Name = "Eform report 2"[/COLOR]

Also, I have a personal belief that VBA's copy & paste is possessed by the devil, as I have never gotten it to work quickly and reliably. Arrays, though painful to learn, are a whole lot better.

Beyond that, it's tough to recommend anything, as it's late and I don't have the slightest clue what your code is doing
Thankfully, using direct commands instead of Selection commands also makes code much more readable.

Please let me know how things turn out, and we'll go from there!

Best Regards,
JTannas

 

[JTannas]

Something I forgot: To make for less jumping around between worksheets, you can use named ranges to refer to cells throughout your workbook.

So you can turn something like this:

Sheet1.Select
Range("A1").Select
Selection.Copy

Sheet2.Select
Range("B2").Select
[COLOR=#333333]Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
[/COLOR]

Into this:

Range("MyRange1").Value = Range("MyRange2").Value

Furthermore, they are more resilient to cell location changes (i.e. add or delete rows & columns to your heart's content ).