geschwiedigkeit des makros verbessern
22.12.2004 15:49:41
hopfennase
ich habe eine exceltabelle mit einem makro, das beim öffnen die daten von einer accesstabelle importiert. allerdings dauert es so wie ich es jetz habe viiiiiiiiiel zu lange.
könnt ihr mir helfen?
wenn es eine möglichkeit geben würde den code schneller zu machen wäre ich froh, bin jedoch auch für ganz neue lösungen ganz ohr.
danke für eue bemühungen
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Sub Workbook_BeforeClose(Cancel As Boolean)
ThisWorkbook.Close False
End Sub
Private Sub Workbook_Open()
'stopp uhr start
Dim s As Long, e As Long
Dim i As Long
s = GetTickCount
Application.ScreenUpdating = False
Cells.Select
Selection.ClearContents
Range("A1").Select
With ActiveSheet.QueryTables.Add(Connection:=Array(Array( _
"ODBC;DSN=Microsoft Access-Datenbank;DBQ=H:\Kundendienst\Intern\KA\Produkte\Seminardatenbank\in arbeit\DB_V6_edit.mdb;DefaultDir=H:\Kund" _
), Array( _
"endienst\Intern\KA\Produkte\Seminardatenbank\in arbeit;DriverId=25;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;" _
)), Destination:=Range("A1"))
.CommandText = Array( _
"SELECT *" & Chr(13) & "" & Chr(10) & "FROM Kursbesuche_Kreuztabelle Kursbesuche_Kreuztabelle" & Chr(13) & "" & Chr(10) & "ORDER BY Kursbesuche_Kreuztabelle.Kostenstelle" _
)
.Name = "Abfrage von Microsoft Access-Datenbank_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.Refresh BackgroundQuery:=False
End With
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Dim rng As Range
Dim c As Range
zeile = [a65536].End(xlUp).Row 'a anpassen?
spalte = [iv1].End(xlToLeft).Column '1 anpassen?
Set rng = Range(Range("A1"), Cells(zeile, spalte)) 'A1 anpassen?
For Each c In rng
c.Borders(xlEdgeBottom).LineStyle = xlContinuous
c.Borders(xlEdgeLeft).LineStyle = xlContinuous
c.Borders(xlEdgeRight).LineStyle = xlContinuous
Next
Rows(1).Borders(xlEdgeBottom).LineStyle = xlNone
lastcolumn = Cells(1, Columns.Count).End(xlToLeft).Column
With Range(Cells(1, 1), Cells(1, lastcolumn)).Borders(xlEdgeBottom)
.LineStyle = xlcontinous
.Weight = xlThick
.ColorIndex = xlautomatc
End With
Columns(4).Borders(xlEdgeRight).LineStyle = xlNone
lastcolumn = Cells(Rows.Count, 3).End(xlUp).Row
With Range(Cells(1, 4), Cells(lastcolumn, 4)).Borders(xlEdgeRight)
.LineStyle = xlcontinous
.Weight = xlThick
.ColorIndex = xlautomatc
End With
'stopuhr ende
e = GetTickCount
MsgBox "Das dauerte " & e - s & " ms"
End Sub