Help with excel automation

[Pirre001]

My code is so slowly, so I guess I need help with the hole code I record from excel. Can someone help me to speed up this code and correct all misstakes I have made. I run this code from my VB project.

Option Explicit
 
Private Const xlColumns = 2
Private Const xlColumnStacked = 52
Dim objGraph As Graph.Chart
 
 
Function IsNothing(Obj As Object) As Boolean
On Error Resume Next
    IsNothing = True
    
    Obj.Name = Obj.Name 'Works even if Object doesn't have a name property
    If Err.Number = 91 Then IsNothing = True
 
End Function
 
 
Function IsExcelRunning() As Boolean
   Dim xlApp As Excel.Application
   On Error Resume Next
 
   Set xlApp = GetObject(, "Excel.Application")
   IsExcelRunning = (Err.Number = 0)
   Set xlApp = Nothing
   Err.Clear
End Function
 
 
Private Function GetExcel() As Excel.Application
   On Error Resume Next
   Set GetExcel = GetObject(, "excel.application")
   If Err.Number <> 0 Then Set GetExcel = New Excel.Application
End Function
 
 
Function OpenXLChange()
 
    Dim db As DAO.Database
    Dim RS As DAO.Recordset
    Dim SQL, PATH As String
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim ExcelRunning As Boolean
    Dim objGraph As Object
    Set objGraph = frmForm1_Excel.OLE1.object ' I included a chart
    
ExcelRunning = IsExcelRunning()
If ExcelRunning = False Then
Set xlApp = CreateObject("Excel.application")
Else
Set xlApp = GetExcel
End If
 
If IsNothing(xlApp) Then Set xlApp = New Excel.Application
 
PATH = "C:\"
    
Set xlBook = xlApp.Workbooks.Open(PATH & MyXl & ".xls")
 
   
    xlBook.Application.Visible = False
    xlApp.ScreenUpdating = False
            
            If frmForm1_Excel.ChkChart = vbChecked Then
            With xlApp.Sheets.Add(After:=Sheets(1))
                xlApp.Sheets(2).Name = "Graf"
            End With
            End If
            
 
xlApp.Sheets(1).Select
 
 With xlApp.Workbooks(1).BuiltinDocumentProperties
.Item("Author").Value = "AuthorName"
.Item("Manager").Value = "ManagerName"
.Item("Title").Value = "TitleText"
.Item("Company").Value = "TheCompany"
.Item("Subject").Value = "SubjectText"
.Item("Comments").Value = "Comments"
End With
 
 
    xlApp.ActiveSheet.PageSetup.PrintArea = ""
    With xlApp.ActiveSheet.PageSetup
        
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
        .LeftHeader = ""
        .CenterHeader = "TestText"
        .RightHeader = "&""Arial,Regular""&8 Sidan &P av &N"
        .LeftFooter = "&""Arial,Regular""&8 TestNr2/&F/TestNr4/&D"
        .CenterFooter = ""
        .RightFooter = "&""Times New Roman,Normal""&3Automatic Created"
        .LeftMargin = xlApp.Application.InchesToPoints(0)
        .RightMargin = xlApp.Application.InchesToPoints(0)
        .TopMargin = xlApp.Application.InchesToPoints(0.984251969)
        .BottomMargin = xlApp.Application.InchesToPoints(0.984251969)
        .HeaderMargin = xlApp.Application.InchesToPoints(0.5)
        .FooterMargin = xlApp.Application.InchesToPoints(0.5)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
 End With
 
 
 
    xlApp.Range("A1:S1").Select
    With xlApp.Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
    End With
    
    xlApp.Cells.Select
    With xlApp.Selection.Font
        .Name = "MS Sans Serif"
        .Size = 8.5
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    
    xlApp.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    xlApp.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With xlApp.Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 15
    End With
    With xlApp.Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 15
    End With
    With xlApp.Selection.Borders(xlEdgeBottom)
        .LineStyle = xlDouble
        .Weight = xlThin
        .ColorIndex = 15
    End With
    With xlApp.Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 15
    End With
    With xlApp.Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 15
    End With
    
        With xlApp.Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 15
    End With
 
    xlApp.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    xlApp.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    
    xlApp.Rows("1:1").Select
   With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = False
    End With
 
    xlApp.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    xlApp.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With xlApp.Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With xlApp.Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With xlApp.Selection.Borders(xlEdgeBottom)
        .LineStyle = xlDouble
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With xlApp.Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With xlApp.Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
 
    xlApp.Columns("D:E").Select
    xlApp.Selection.NumberFormat = "yyyy-mm-dd"
    xlApp.Columns("H:S").Select
    xlApp.Selection.AutoFilter
    
    xlApp.Cells.Select
    xlApp.Cells.EntireColumn.AutoFit
    
    xlApp.ActiveWindow.View = xlPageBreakPreview
    xlApp.ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
    xlApp.ActiveWindow.View = xlNormalView
    
    xlApp.Range("A1").Select
    
    SQL = "Mys SQL statement"
    
    Set db = OpenDatabase(GetTmpPath & "TestMDB.MDB", False, True, ";pwd=******")
    Set RS = db.OpenRecordset(SQL, dbOpenDynaset)
 
    While Not RS.EOF
    With xlApp.Range("A" & RS.AbsolutePosition + 2).AddComment
    .Visible = False
    .Text Text:=RTrim(RS.FIELDS("Name").Value) & Chr(10) & _
    "Faxnr: " & RTrim(RS.FIELDS("FaxNumber"))
    .Shape.ScaleWidth 1.63, False
    .Shape.ScaleHeight 1.38, False
    End With
    RS.MoveNext
    Wend
    RS.Close
    
 
   If frmForm1_Excel.ChkChart = vbChecked Then
    xlApp.Sheets("Graf").Select
    objGraph.ChartArea.Copy
    xlApp.Cells.Select
    xlApp.ActiveSheet.Paste
    
    xlApp.ActiveSheet.Shapes("Object 1").Select ' Here is the copied chart
    xlApp.Selection.ShapeRange.ScaleWidth 0.88, False
    With xlApp.ActiveSheet.PageSetup
        
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
        .LeftHeader = ""
        .CenterHeader = "TestText"
        .RightHeader = "&""Arial,Regular""&8 Sidan &P av &N"
        .LeftFooter = "&""Arial,Regular""&8 TestNr2/&F/TestNr4/&D"
        .CenterFooter = ""
        .RightFooter = "&""Times New Roman,Normal""&3Automatic Created"
        .LeftMargin = xlApp.Application.InchesToPoints(0)
        .RightMargin = xlApp.Application.InchesToPoints(0)
        .TopMargin = xlApp.Application.InchesToPoints(0.984251969)
        .BottomMargin = xlApp.Application.InchesToPoints(0.984251969)
        .HeaderMargin = xlApp.Application.InchesToPoints(0.5)
        .FooterMargin = xlApp.Application.InchesToPoints(0.5)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
    End With
    
    Set objGraph = Nothing
    End If
 
xlBook.Save
xlBook.Close
 
xlApp.Quit
         
        Set xlBook = Nothing
        Set xlApp = Nothing
        Set db = Nothing
        Set RS = Nothing
 
End Function

[nickjc67]

I always find excel VB programs very slow because it insists on displaying the results as it goes. If you switch off the scren updating while it is running then it will speed up. Hope this helps.

Nick