Makro optimieren
09.06.2006 11:44:59
Thomas
Ich hab folgendes Makro. Es funktioniert auch ohne Probleme, ABER dauert eindeutig zu lange.
Ich hoffe jemand kann sich den code mal anschauen und mir helfen es zu optimieren (vor allem Rechnenzeit).
Meine Kenntnisse in VB sind eher begrenzt.
Das Makro befindet sich in einer xls Datei im Sheet("Uebersicht")
Quellpfad und Zielpfad stehen im Sheet in einer zelle
Das Makro soll folgendes ausfuehren:
Es soll ab Cells(11,4) ueberprufen ob die Zelle leer ist und die dazugehoerige checkbox aktiv ist.
In diesen Zellen steht der Dateiname (Quellname).
Falls ja, wird ein neues Workbook mit den namen "BZ_System" erstellt.
ein neues sheet wird erstellt mit dateinamen aus zelle (OHNE die Dateiendung)
Dann wird die Datei mit dateinamen Cells(11,4) importiert (ist eine .csv Datei).
Dananach wird die naechste Zelle (Cells(12,4)) aus Sheet("Uebersicht") sowie die Checkbox abgefragt.
Bei Ja wird in der erstellten Datei "BZ_System" eines neues sheet erstellt und die Datei mit dateinamen=Cells(12,4)
importiert.
usw.
Bis eine zelle leer ist.
Zum schluss werden alle leeren sheets geloescht, sodass nur die vom makro erstellten sheets in der datei sind.
Z.B. hab ich dann in der Datei die 3 Sheets BZ2, BZ1, BZ0
Dann wird ein weiteres makro aufgerufen was die erstellten sheets bearbeitet (Makro heisst Mehrere_Protool_CSV_Blätter_umkopieren).
Das ergebniss ist dann folgende sheets in der reihenfolge
Tabelle1 , _BZ2 , BZ2 , _BZ1, BZ1, _BZ0, BZ
Ab jetzt
Sub rest
Ich moechte dann das alle sheets die nicht mit _ anfangen geloescht werden.
Im naechsten schritt werden dann ein neues sheet BZ_Szstem_ges erstellt und die Daten aus _BZ0 eingefuegt.
Danach BZ_1 (ohne die erste Zeile!!!!) ans ende von BZ_Szstem_ges.
Danach BZ_2 (ohne die erste Zeile!!!!) ans ende von BZ_Szstem_ges.
Alle Sheets bis auf BZ_Szstem_ges loeschen.
Nach moeglichkeit sollte das makro ohne exakt angegeben namen auskommen, da ich es nicht nur fuer BZ Dateien verwenden will.
Das wars und der Leser ist verwirrt, richtig?
Hier mal der code. vielleicht wird dann klar was ich will.
Sub BZ_System_einlesen()
Quellordner = Sheets("Übersicht").Cells(6, 8)
Zielordner = Sheets("Übersicht").Cells(7, 8)
ToolPfad = ActiveWorkbook.Path
Toolname = ActiveWorkbook.Name
'Toolname = Replace(Toolname, ".xls", "")
Cells(25, 25) = Toolname
w = Sheets("Übersicht").Cells(2, 41)
'Cells(21, 20) = w
'w = 3
v = 0
Zieldatei_old = "BZ_System.xls"
Zielordner = Sheets("Übersicht").Cells(7, 8)
Zieldatei = Zielordner & "\" & Zieldatei_old
Workbooks.Add
ActiveWorkbook.SaveAs Filename:= _
Zieldatei, FileFormat _
:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
Zielname = ActiveWorkbook.Name
'Zielname = Replace(Zielname, ".xls", "")
Do While v < w
Workbooks(Toolname).Activate
checkBoxName = "CheckBox_BZ_System" & (v + 1)
If Sheets("Übersicht").Cells(v + 11, 4) <> 0 And Sheets("Übersicht").OLEObjects(checkBoxName).Object.Value = True Then
'Sheets("Übersicht").OLEObjects(checkBoxName).Object.Value = True Then
Quelldatei_old = Sheets("Übersicht").Cells(v + 11, 4).Value
'Zieldatei_old = "BZ_System.xls"
Name = Replace(Quelldatei_old, ".csv", "")
Quelldatei = "TEXT;" & Quellordner & "\" & Quelldatei_old
'End If
'v = v + 1
'Loop
'End Sub
'
Sub bla()
Workbooks(Zielname).Activate
Sheets.Add
ActiveSheet.Name = Name
With ActiveSheet.QueryTables.Add(Connection:= _
Quelldatei, Destination:= _
Range("A1"))
.Name = Name
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 932
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
' .TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End If
Loop
'Alle leeren sheets löschen
Workbooks(Zieldatei_old).Activate
Dim i As Integer
Application.DisplayAlerts = False
On Error Resume Next
For i = ActiveWorkbook.Sheets.Count To 1 Step -1
Sheets(i).Activate
If ActiveCell.SpecialCells(xlLastCell).Address = _
"$A$1" Then Sheets(i).Delete
Next i
Application.DisplayAlerts = True
Call Mehrere_Protool_CSV_Blätter_umkopieren
End Sub
Sub rest()
' löschen bis auf zusammengefasste
Dim i As Integer
Application.DisplayAlerts = False
On Error Resume Next
For i = 3 To ActiveWorkbook.Sheets.Count Step 2
Sheets(i).Delete
Next i
Application.DisplayAlerts = True
' Zusammenfassen
Sheets.Add
ActiveSheet.Name = "BZ_System_ges"
Dim intBlatt As Integer, lngZeile As Long
Sheets(1).Cells.Clear
For intBlatt = Worksheets.Count To 2 Step -1
Worksheets(intBlatt).UsedRange.EntireRow.Copy Worksheets(1).Cells(lngZeile + 1, 1)
lngZeile = lngZeile + Worksheets(intBlatt).UsedRange.Rows.Count
Next intBlatt
' löschen bis auf zusammengefasste
Application.DisplayAlerts = False
On Error Resume Next
For i = ActiveWorkbook.Sheets.Count To 2 Step -1
Sheets(i).Delete
Next i
Application.DisplayAlerts = True
' Speichern und schliessen
ActiveWorkbook.Save
ActiveWindow.Close
End Sub
---------------------------------------------------------
Danke schon mal im voraus
Gruss
Thomas