Super Slow Macro HELP!!

chomsky

chomsky

Board Regular
Joined
Mar 13, 2009
Messages
178
This macro slows down and freezes some times. How can I Speed it up.?

Code: 
Sub Paperlistmacro()
Call ExtractoPLConv
Call ExtractoPLDonor
Call ExtractoPLRP
Application.Calculation = xlManual
Application.ScreenUpdating = False
Call AddHeaderToAll_FromCurrentSheet
Sheets("CONVERSIONES").Select
ActiveSheet.UsedRange.Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
Columns("O:O").Select
    With Selection.Font
        .Name = "Arial"
        .FontStyle = "Bold"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
Range("A1").Select
Call MenuPWTI.Group_Underline
Sheets("DONORS").Select
ActiveSheet.UsedRange.Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
Columns("E:E").Select
    With Selection.Font
        .Name = "Arial"
        .Size = 14
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
Range("C1:D1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Interior.ColorIndex = 36
Range("E1").Select
Call MenuPWTI.Group_Underline
Sheets("RP's").Select
ActiveSheet.UsedRange.Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
Columns("E:E").Select
    With Selection.Font
        .Name = "Arial"
        .FontStyle = "Bold"
        .Size = 16
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
Range("E2").Select
Call MenuPWTI.Group_Underline
ActiveWorkbook.Save
Worksheets(2).Activate
Application.Calculation = xlAutomatic
End Sub
                            'ÇONVERSIONES
Sub ExtractoPLConv()
    If FileThere("C:\PAPERLIST" & "\PAPERLISTTEMPLATE.xls") Then
        GetDataExtractoPLConv ("C:\PAPERLIST" & "\PAPERLISTTEMPLATE.xls"), "", "DataRangeC", Sheets _
        ("CONVERSIONES").Range("CStartC"), False, False
    Else
        MsgBox ("El File PAPERLISTTEMPLATE.xls no ha sido encontrado. Click OK para continuar")
    End If
End Sub
 
Public Sub GetDataExtractoPLConv(SourceFile As Variant, SourceSheet As String, SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim n As Integer
Dim row, m As Integer
Dim myRange As Range
    ' Create the connection string.
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
        End If
 
    If SourceSheet = "" Then
    ' workbook level name
        szSQL = "SELECT [ExptName],[EUSourceName],[SourcePedigree],[VarietyName],[EventName],[X],[Y],[EntryNumber],[EntryRole],[EUIdentifier],[EntryInstructions],[EntryComments],[GrowingFemaleEntryNumber],[GrowingFemaleExpt_Name],[EUInventoryID],[Box] FROM " & SourceRange$ & " WHERE [EUIdentifier] <> 0  ORDER BY [ExptName],[EntryNumber];"
    
    Else
    
    ' worksheet level name or range
        szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
    End If
    'On Error GoTo SomethingWrong
    Set rsCon = CreateObject("ADODB.Connection")
    Set rsData = CreateObject("ADODB.Recordset")
    rsCon.Open szConnect
    rsData.Open szSQL, rsCon, 0, 1, 1
    ' Check to make sure we received data and copy the data
 
    If Not rsData.EOF Then
            
            'code to populate values onto Spreadsheet
        
        Set myRange = Worksheets("CONVERSIONES").Range("CStartC")
        myRange.CopyFromRecordset rsData
        
    Else
            MsgBox "No records de conversiones returned from : " & SourceFile, vbCritical
    End If
    
   
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
End Sub
                                          
                                   
                                   'DONORS PAPERLISTS
Sub ExtractoPLDonor()
    If FileThere("C:\PAPERLIST" & "\PAPERLISTTEMPLATE.xls") Then
        GetDataExtractoPLDonor ("C:\PAPERLIST" & "\PAPERLISTTEMPLATE.xls"), "", "DataRangeC", Sheets _
        ("DONORS").Range("CStartD"), False, False
    Else
        MsgBox ("El File PAPERLISTTEMPLATE.xls no ha sido encontrado. Verifique que tenga el Template Grabado En su Local Disk(C:\). Click OK para continuar")
    End If
End Sub
 
Public Sub GetDataExtractoPLDonor(SourceFile As Variant, SourceSheet As String, SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim n As Integer
Dim row, m As Integer
Dim myRange As Range
    ' Create the connection string.
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
        End If
 
    If SourceSheet = "" Then
    ' workbook level name
        szSQL = "SELECT [ExptName],[EntryInstructions],[X],[Y],[VarietyName],[EntryNumber],[Box] FROM " & SourceRange$ & " WHERE (Len([VarietyName])<>5 AND [VarietyName] <> 'DEADCORN') AND ([EUSourceName] NOT LIKE 'PW%') AND ([VarietyName] NOT LIKE 'TI%') ORDER BY [VarietyName],[Y],[X];"
    
    Else
    
    ' worksheet level name or range
        szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
    End If
    'On Error GoTo SomethingWrong
    Set rsCon = CreateObject("ADODB.Connection")
    Set rsData = CreateObject("ADODB.Recordset")
    rsCon.Open szConnect
    rsData.Open szSQL, rsCon, 0, 1, 1
    ' Check to make sure we received data and copy the data
 
    If Not rsData.EOF Then
            
            'code to populate values onto Spreadsheet
        
        Set myRange = Worksheets("DONORS").Range("CStartD")
        myRange.CopyFromRecordset rsData
        
    Else
            MsgBox "No Donors records returned from : " & SourceFile, vbCritical
    End If
    
   
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
End Sub
                                
                                'RP's
Sub ExtractoPLRP()
    If FileThere("C:\PAPERLIST" & "\PAPERLISTTEMPLATE.xls") Then
        GetDataExtractoPLRP ("C:\PAPERLIST" & "\PAPERLISTTEMPLATE.xls"), "", "DataRangeC", Sheets _
        ("RP's").Range("CStartRP"), False, False
    Else
        MsgBox ("El File PAPERLISTTEMPLATE.xls no ha sido encontrado. Click OK para continuar")
    End If
End Sub
 
Public Sub GetDataExtractoPLRP(SourceFile As Variant, SourceSheet As String, SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim n As Integer
Dim row, m As Integer
Dim myRange As Range
    ' Create the connection string.
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
        End If
 
    If SourceSheet = "" Then
    ' workbook level name
        szSQL = "SELECT [ExptName],[EntryInstructions],[X],[Y],[VarietyName],[EntryNumber],[Box] FROM " & SourceRange$ & " WHERE (Len([VarietyName]) = 5) ORDER BY [VarietyName],[Y],[X];"
    
    Else
    
    ' worksheet level name or range
        szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
    End If
    'On Error GoTo SomethingWrong
    Set rsCon = CreateObject("ADODB.Connection")
    Set rsData = CreateObject("ADODB.Recordset")
    rsCon.Open szConnect
    rsData.Open szSQL, rsCon, 0, 1, 1
    ' Check to make sure we received data and copy the data
 
    If Not rsData.EOF Then
            
            'code to populate values onto Spreadsheet
        
        Set myRange = Worksheets("RP's").Range("CStartRP")
        myRange.CopyFromRecordset rsData
        
    Else
            MsgBox "No RP records returned from : " & SourceFile, vbCritical
    End If
    
   
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
End Sub
Sub AddHeaderToAll_FromCurrentSheet()
     'Add A1 from active sheet to each sheets's header
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        'ws.PageSetup.CenterHeader = Worksheets("BOLITA").Range("A3").Value
            With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftHeader = Worksheets("BOLITA").Range("A3").Value & Chr(10) & "Hora Comienzo:"
        .CenterHeader = "" & Chr(10) & "Nombre:"
        .RightHeader = "&A" & Chr(10) & "Hora Salida:"
        .LeftFooter = "&BPioneer, A DuPont Company Confidential&B"
        .CenterFooter = "&D"
        .RightFooter = "Page &P"
        .LeftMargin = Application.InchesToPoints(0.75)
        .RightMargin = Application.InchesToPoints(0.75)
        .TopMargin = Application.InchesToPoints(1)
        .BottomMargin = Application.InchesToPoints(1)
        .HeaderMargin = Application.InchesToPoints(0.5)
        .FooterMargin = Application.InchesToPoints(0.5)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 95
        .PrintErrors = xlPrintErrorsDisplayed
    End With
    Application.WindowState = xlMinimized
    Application.WindowState = xlNormal
    Next ws
    
End Sub

Sub WorksheetLoopPL()
   Dim WS_Count As Integer
   Dim I As Integer
   ' Set WS_Count equal to the number of worksheets in the active
   ' workbook.
   WS_Count = ActiveWorkbook.Worksheets.Count
   ' Begin the loop.
   For I = 1 To WS_Count
   
   Worksheets(I).Activate
          
    'Header y Footer
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftHeader = "&A" & Chr(10) & "Hora Comienzo:"
        .CenterHeader = "" & Chr(10) & "Nombre:"
        .RightHeader = "&A" & Chr(10) & "Hora Salida:"
        .LeftFooter = "&BPioneer, A DuPont Company Confidential&B"
        .CenterFooter = "&D"
        .RightFooter = "Page &P"
        .LeftMargin = Application.InchesToPoints(0.75)
        .RightMargin = Application.InchesToPoints(0.75)
        .TopMargin = Application.InchesToPoints(1)
        .BottomMargin = Application.InchesToPoints(1)
        .HeaderMargin = Application.InchesToPoints(0.5)
        .FooterMargin = Application.InchesToPoints(0.5)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 95
        .PrintErrors = xlPrintErrorsDisplayed
    End With
    Application.WindowState = xlMinimized
    Application.WindowState = xlNormal
             
      ' Insert your code here.
      ' The following line shows how to reference a sheet within
      ' the loop by displaying the worksheet name in a dialog box.
     
   Next I
End Sub
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Sort by date Sort by votes
Anything to do with page setup will slow things down, and there's not much you can do about it because it's actually a printer driver issue.

As for the rest of the code, I really think you need to tidy it up.:)
 
Upvote 0
Sheets(Array("CONVERSIONES", "DONORS", "RP's")).Select
Sheets("CONVERSIONES").Activate
With ActiveSheet.PageSetup
.LeftHeader = Worksheets("BOLITA").Range("A3").Value & Chr(10) & "Hora Comienzo:"
.CenterHeader = "" & Chr(10) & "Nombre:"
.RightHeader = "&A" & Chr(10) & "Hora Salida:"
.LeftFooter = "&BPioneer, A DuPont Company Confidential&B"
.CenterFooter = "&D"
.RightFooter = "Page &P"
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 300
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.BlackAndWhite = False
.Zoom = 95
.PrintErrors = xlPrintErrorsDisplayed
End With

Enven like this Still Slow.!!!!!!!! Help please.
 
Upvote 0
chomsky said:
Any ohter way to do it ?
Click to expand...
Have you tried ExecuteExcel4Macro?
It’s faster in times than your code.

Other recommendations:
1. Set page settings manually and save workbook - it saves the page settings too, therefore slow part of VBA code is not required.
2. Don’t use network printer while code with page settings is running. If possible use the local printer as default.
3. Don't display page breaks
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
formating question
Replies
3
Views
297
Micron
M
L
  • Locked
  • Question Question
Help Cleaning Up Code
Replies
2
Views
571
RoryA
RoryA
K
  • Solved
create a button that do actions
2 3
Replies
22
Views
1K
kerm007
K
P
  • Question Question
Excel to internal application
Replies
2
Views
442
pure vito
P
J
  • Question Question
Issue with Macros and renaming files
Replies
6
Views
978
kevin9999
K

Forum statistics

Threads
1,222,720
Messages
6,167,837
Members
452,147
Latest member
Ckaplan

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top