Live-Forum - Die aktuellen Beiträge
Datum
Titel
18.04.2024 21:09:11
4 Spalten aus smarter Tabelle in andere smarte Tab. kopieren
18.04.2024 20:45:35
Worksheet_Activate für alle Sheets
18.04.2024 19:30:20
VBA - Tabelle mit Mannschaftsergebnissen sortieren
18.04.2024 18:04:29
Formel fehler Wert#
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1180to1184
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1180to1184
1180to1184
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Schleifendauer

Schleifendauer
Ralf_P
Hallo zusammen,
ich habe in einem scipt eine Schleife, die nacheinander die jeweils letzte Zeile von csv Dateien in sheet 2 schreibt, die Werte auf sheet 1 überträgt, danach die Einträge in sheet 2 löscht und die nächste csv einliest.
Das klappt auch alles hervorragend, da es sich aber insgesamt um ca. 6.300 csv Dateien handelt, wird die Zeit für den Schleifendurchlauf ab ca. 2.500 abgearbeiteten csv Dateien immer langsamer.
Mir ist noch nicht ganz klar woran das liegen könnte, denn der Arbeitsspeicher und die Prozessorauslastung bleibt von Anfang bis Ende annähernd gleich.
Vielleicht weiss ja einer von Euch weiter.
Hier mal der Code-Schnipsel mit der For-Next-Schleife:
'Zähler (z) für Gesamtanzahl der Dateien initialisieren
For i = 0 To ListAnzahl_csv - 1
If UserForm4.ListBox1.Selected(i) = True Then
z = z + 1
End If
Next
UserForm4.Label4.Caption = z
'Zähler (zz) für verbleibende Anzahl der Dateien initialisieren
zz = z
'Label für Fortschrittanzeige einblenden
UserForm4.Label4.Visible = True
UserForm4.Label5.Visible = True
UserForm4.Label6.Visible = True
UserForm4.Label7.Visible = True
UserForm4.Label8.Visible = True
UserForm4.Label9.Visible = True
'Tabelle anlegen und Überschriften einfügen
Workbooks.Add
Sheets(1).Activate
Cells(1, 1).Value = "KBS"
Cells(1, 2).Value = "Strecke"
Cells(1, 3).Value = "Teilstrecken Nr."
Cells(1, 4).Value = "Start"
Cells(1, 5).Value = "Ziel"
Cells(1, 6).Value = "Start Name"
Cells(1, 7).Value = "Ziel Name"
Cells(1, 8).Value = "Haltemuster"
Cells(1, 9).Value = "MF-Trakt."
Cells(1, 10).Value = "Fahrzeug"
Cells(1, 11).Value = "Auslastung"
Cells(1, 12).Value = "Extension"
Cells(1, 13).Value = "Weg [m]"
Cells(1, 14).Value = "Zeit [hh:mm:ss]"
Cells(1, 15).Value = "Energie ab Fahrleitung [KWh]"
Cells(1, 16).Value = "Bremsenergie ab Fahrleitung [KWh]"
'Dateinamen erstellen und neue Tabelle speichern
overview = sPath & "dpf\" & "Verbrauchsübersicht_" & PROJEKT & ".xls"
ActiveWorkbook.SaveAs overview
'
'###################################################################################################################
'Alle vorhandenen CSV auflisten und prüfen, welche ausgewählt wurden
'###################################################################################################################
For i = 0 To ListAnzahl_csv - 1
If UserForm4.ListBox1.Selected(i) = True Then
csvDatei = sPath & "dpf\" & UserForm4.ListBox1.List(i) & ".csv"
If FileLen(csvDatei) Fehlerliste = Fehlerliste & vbCrLf & csvDatei
Fehlerzähler = Fehlerzähler + 1
'MsgBox über Fehlerhafte Dateien wird am Ende des Scripts eingeblendet
Name (csvDatei) As (csvDatei & ".err")
GoTo FEHLER
End If
csvName = UserForm4.ListBox1.List(i) & ".csv"
xlsName = sPath & "dpf\" & UserForm4.ListBox1.List(i) & ".xls"
'Zähler (zz) für verbleibende Anzahl der Dateien aktualisieren
If i > 0 Then zz = zz - 1
UserForm4.Label5.Caption = zz
proz = (100 - ((zz / z) * 100)) * 3
UserForm4.Label8.Width = proz
'UserForm4.Label10.Caption = Round(proz / 3, 1) & " %"
UserForm4.Label10.Caption = Int(proz / 3) & " %"
DoEvents
'
'###################################################################################################################
'Überschriften aus Dateinamen auslesen - unterscheiden nach
'Teilstrecke mit Nummer, Teilstrecke ohne Nummer, Hauptstrecke
'###################################################################################################################
kbs = Mid(csvName, 6, 3)
NUMMER = Mid(csvName, 10, 1)
If NUMMER Like "#" Then
NUMMER = True
Else
NUMMER = False
End If
'
If NUMMER = True Then
strecke = "TeilStr"
streckeNr = Mid(csvName, 10, 2)
Start = Mid(csvName, 13, 4)
ziel = Mid(csvName, 18, 4)
expr = ""
MFtrakt = Mid(csvName, 23, 2)
fahrzeug = Mid(csvName, 25, 3)
auslastung = Mid(csvName, 28, 3)
extension = Mid(csvName, 32, 3)
ElseIf Mid(csvName, 10, 1) = "_" And Mid(csvName, 11, 1) = "_" Then
strecke = "TeilStr"
streckeNr = ""
Start = Mid(csvName, 13, 4)
ziel = Mid(csvName, 18, 4)
expr = ""
MFtrakt = Mid(csvName, 23, 2)
fahrzeug = Mid(csvName, 25, 3)
auslastung = Mid(csvName, 28, 3)
extension = Mid(csvName, 32, 3)
ElseIf Mid(csvName, 10, 1) "_" And NUMMER = False Then
strecke = "HauptStr"
streckeNr = ""
Start = Mid(csvName, 10, 4)
ziel = Mid(csvName, 15, 4)
expr = Mid(csvName, 20, 2)
MFtrakt = Mid(csvName, 23, 2)
fahrzeug = Mid(csvName, 25, 3)
auslastung = Mid(csvName, 28, 3)
extension = Mid(csvName, 32, 3)
End If
'
'###################################################################################################################
'Daten aus markierten (gewählten) csv Protokolldateien in Tabelle 2 einlesen
'###################################################################################################################
Sheets(2).Activate
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & csvDatei, _
Destination:=Range("A1"))
.Name = csvName
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
'###################################################################################################################
'Daten aus aktueller csv Protokolldatei in Tabelle 1, jeweils letzte Zeile übertragen
'###################################################################################################################
Sheets(1).Activate
n = Cells(Rows.Count, 1).End(xlUp).Row + 1
x = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
'
Cells(n, 1).Value = kbs
Cells(n, 2).Value = strecke
Cells(n, 3).NumberFormat = "00"
Cells(n, 3).Value = streckeNr
Cells(n, 4).Value = Start
Cells(n, 5).Value = ziel
Cells(n, 6).Value = Sheets(2).Cells(2, 1).Value
Cells(n, 7).Value = Sheets(2).Cells(x, 1).Value
Cells(n, 8).Value = expr
Cells(n, 9).Value = MFtrakt
Cells(n, 10).Value = fahrzeug
Cells(n, 11).Value = auslastung
Cells(n, 12).Value = extension
Cells(n, 13).Value = Sheets(2).Cells(x, 3).Value
Cells(n, 14).Value = Sheets(2).Cells(x, 5).Value / 86400
Cells(n, 14).NumberFormat = "h:mm:ss;@"
Cells(n, 15).Value = Round(Sheets(2).Cells(x, 7).Value, 2)
Cells(n, 15).NumberFormat = "0.00"
Cells(n, 16).Value = Round(Sheets(2).Cells(x, 9).Value, 2)
Cells(n, 16).NumberFormat = "0.00"
'###################################################################################################################
'Daten in Tabelle 2 löschen, um nächste csv Datei einzulesen
'###################################################################################################################
Sheets(2).Cells().Delete
End If
FEHLER:
Next
'###################################################################################################################
'Tabelle 2 löschen und Tabelle 1 formatieren
'###################################################################################################################
'
ActiveWorkbook.Sheets(2).Delete
Viele Grüße, Ralf

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Schleifendauer
21.10.2010 14:21:38
Holger
Hallo,
hm, ich sehe nicht, dass du folgendes gesetzt hast:
Sub So
Application.screenupdating = false
Application.enableevents = false
Application.calculation = xlcalculationmanual
End Sub
Das würde ich immer als erstes machen bevor ich an den Code gehe.
AW: Schleifendauer
21.10.2010 14:49:54
Ralf_P
Hallo Holger,
das ist ja auch nur ein Ausschnitt aus dem Gesamtcode.
Application.screenupdating = false ==> ist gesetzt
Application.enableevents = false ==> ist gesetzt
Application.calculation = xlcalculationmanual ==> ist nicht gesetzt
Dürfte aber m. E. nicht ausschlaggebend sein, da nur Werte übertragen werden.
Es werden auf sheet 1 keinerlei Formeln eingetragen, die eine Neukalkulation hervorrufen.
Hier noch der Gesamtabschnitt: 
Sub csv_to_xls()
Dim csvDatei As String
Dim csvName As String
Dim xlsName As String
Dim overview As String
Dim kbs As String
Dim strecke As String
Dim streckeNr As String
Dim Start As String
Dim ziel As String
Dim expr As String
Dim start_name As String
Dim ziel_name As String
Dim MFtrakt As String
Dim fahrzeug As String
Dim auslastung As String
Dim extension As String
Dim c As Integer
Dim i As Integer
Dim n As Long
Dim x As Integer
Dim z As Long
Dim zz As Long
Dim proz As Integer
Dim NUMMER As Variant
Dim Fehlerliste As String
Dim Fehlerzähler As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 2
'Zähler (z) für Gesamtanzahl der Dateien initialisieren
For i = 0 To ListAnzahl_csv - 1
If UserForm4.ListBox1.Selected(i) = True Then
z = z + 1
End If
Next
UserForm4.Label4.Caption = z
'Zähler (zz) für verbleibende Anzahl der Dateien initialisieren
zz = z
'Label für Fortschrittanzeige einblenden
UserForm4.Label4.Visible = True
UserForm4.Label5.Visible = True
UserForm4.Label6.Visible = True
UserForm4.Label7.Visible = True
UserForm4.Label8.Visible = True
UserForm4.Label9.Visible = True
'Tabelle anlegen und Überschriften einfügen
Workbooks.Add
Sheets(1).Activate
Cells(1, 1).Value = "KBS"
Cells(1, 2).Value = "Strecke"
Cells(1, 3).Value = "Teilstrecken Nr."
Cells(1, 4).Value = "Start"
Cells(1, 5).Value = "Ziel"
Cells(1, 6).Value = "Start Name"
Cells(1, 7).Value = "Ziel Name"
Cells(1, 8).Value = "Haltemuster"
Cells(1, 9).Value = "MF-Trakt."
Cells(1, 10).Value = "Fahrzeug"
Cells(1, 11).Value = "Auslastung"
Cells(1, 12).Value = "Extension"
Cells(1, 13).Value = "Weg [m]"
Cells(1, 14).Value = "Zeit [hh:mm:ss]"
Cells(1, 15).Value = "Energie ab Fahrleitung [KWh]"
Cells(1, 16).Value = "Bremsenergie ab Fahrleitung [KWh]"
'Dateinamen erstellen und neue Tabelle speichern
overview = sPath & "dpf\" & "Verbrauchsübersicht_" & PROJEKT & ".xls"
ActiveWorkbook.SaveAs overview
'############################################################################################### _
'Alle vorhandenen CSV auflisten und prüfen, welche ausgewählt wurden
'############################################################################################### _
For i = 0 To ListAnzahl_csv - 1
If UserForm4.ListBox1.Selected(i) = True Then
csvDatei = sPath & "dpf\" & UserForm4.ListBox1.List(i) & ".csv"
If FileLen(csvDatei)  0 Then zz = zz - 1
UserForm4.Label5.Caption = zz
proz = (100 - ((zz / z) * 100)) * 3
UserForm4.Label8.Width = proz
'UserForm4.Label10.Caption = Round(proz / 3, 1) & " %"
UserForm4.Label10.Caption = Int(proz / 3) & " %"
DoEvents
'####################################################################################### _
'Überschriften aus Dateinamen auslesen - unterscheiden nach
'Teilstrecke mit Nummer, Teilstrecke ohne Nummer, Hauptstrecke
'####################################################################################### _
kbs = Mid(csvName, 6, 3)
NUMMER = Mid(csvName, 10, 1)
If NUMMER Like "#" Then
NUMMER = True
Else
NUMMER = False
End If
If NUMMER = True Then
strecke = "TeilStr"
streckeNr = Mid(csvName, 10, 2)
Start = Mid(csvName, 13, 4)
ziel = Mid(csvName, 18, 4)
expr = ""
MFtrakt = Mid(csvName, 23, 2)
fahrzeug = Mid(csvName, 25, 3)
auslastung = Mid(csvName, 28, 3)
extension = Mid(csvName, 32, 3)
ElseIf Mid(csvName, 10, 1) = "_" And Mid(csvName, 11, 1) = "_" Then
strecke = "TeilStr"
streckeNr = ""
Start = Mid(csvName, 13, 4)
ziel = Mid(csvName, 18, 4)
expr = ""
MFtrakt = Mid(csvName, 23, 2)
fahrzeug = Mid(csvName, 25, 3)
auslastung = Mid(csvName, 28, 3)
extension = Mid(csvName, 32, 3)
ElseIf Mid(csvName, 10, 1)  "_" And NUMMER = False Then
strecke = "HauptStr"
streckeNr = ""
Start = Mid(csvName, 10, 4)
ziel = Mid(csvName, 15, 4)
expr = Mid(csvName, 20, 2)
MFtrakt = Mid(csvName, 23, 2)
fahrzeug = Mid(csvName, 25, 3)
auslastung = Mid(csvName, 28, 3)
extension = Mid(csvName, 32, 3)
End If
'####################################################################################### _
'Daten aus markierten (gewählten) csv Protokolldateien in Tabelle 2 einlesen
'####################################################################################### _
Sheets(2).Activate
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & csvDatei, _
Destination:=Range("A1"))
.Name = csvName
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
'####################################################################################### _
'Daten aus aktueller csv Protokolldatei in Tabelle 1, jeweils letzte Zeile übertragen
'####################################################################################### _
Sheets(1).Activate
n = Cells(Rows.Count, 1).End(xlUp).Row + 1
x = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
Cells(n, 1).Value = kbs
Cells(n, 2).Value = strecke
Cells(n, 3).NumberFormat = "00"
Cells(n, 3).Value = streckeNr
Cells(n, 4).Value = Start
Cells(n, 5).Value = ziel
Cells(n, 6).Value = Sheets(2).Cells(2, 1).Value
Cells(n, 7).Value = Sheets(2).Cells(x, 1).Value
Cells(n, 8).Value = expr
Cells(n, 9).Value = MFtrakt
Cells(n, 10).Value = fahrzeug
Cells(n, 11).Value = auslastung
Cells(n, 12).Value = extension
Cells(n, 13).Value = Sheets(2).Cells(x, 3).Value
Cells(n, 14).Value = Sheets(2).Cells(x, 5).Value / 86400
Cells(n, 14).NumberFormat = "h:mm:ss;@"
Cells(n, 15).Value = Round(Sheets(2).Cells(x, 7).Value, 2)
Cells(n, 15).NumberFormat = "0.00"
Cells(n, 16).Value = Round(Sheets(2).Cells(x, 9).Value, 2)
Cells(n, 16).NumberFormat = "0.00"
'####################################################################################### _
'Daten in Tabelle 2 löschen, um nächste csv Datei einzulesen
'####################################################################################### _
Sheets(2).Cells().Delete
End If
FEHLER:
Next
'############################################################################################### _
'Tabelle 2 löschen und Tabelle 1 formatieren
'############################################################################################### _
ActiveWorkbook.Sheets(2).Delete
Sheets(1).Activate
'Spaltenbreite festlegen
Columns("A:A").ColumnWidth = 7
Columns("B:B").ColumnWidth = 10
Columns("C:C").ColumnWidth = 15
Columns("D:D").ColumnWidth = 10
Columns("E:E").ColumnWidth = 10
Columns("F:F").ColumnWidth = 20
Columns("G:G").ColumnWidth = 20
Columns("H:H").ColumnWidth = 12
Columns("I:I").ColumnWidth = 10
Columns("J:J").ColumnWidth = 10
Columns("K:K").ColumnWidth = 12
Columns("L:L").ColumnWidth = 12
Columns("M:M").ColumnWidth = 12
Columns("N:N").ColumnWidth = 16
Columns("O:O").ColumnWidth = 33
Columns("P:P").ColumnWidth = 33
'Autofilter setzen
Rows("1:1").AutoFilter
Range("A2").Select
'Fenster fixieren
ActiveWindow.FreezePanes = True
'Tabelle nach Fahrzeugtyp sortieren
With ActiveSheet.UsedRange
.Sort Key1:=Range("J2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
'Zeile 1 schwarz mit weißem Text
Range(Cells(1, 1), Cells(1, ActiveSheet.UsedRange.Columns.Count)).Interior.ColorIndex = 1
Range(Cells(1, 1), Cells(1, ActiveSheet.UsedRange.Columns.Count)).Font.ColorIndex = 2
'jede zweite Zeile hellgrau
For n = 2 To ActiveSheet.UsedRange.Rows.Count
If n Mod 2  1 Then
Range(Cells(n, 1), Cells(n, ActiveSheet.UsedRange.Columns.Count)).Interior.ColorIndex =  _
15
End If
Next n
'Druckbereich festlegen
ActiveSheet.PageSetup.PrintArea = ActiveSheet.UsedRange.Address
'Wiederholungszeilen festlegen
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
End With
'Fußzeile festlegen
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "&Z&F"
.CenterFooter = ""
.RightFooter = "Seite &P von &N"
.LeftMargin = Application.InchesToPoints(0.787401575)
.RightMargin = Application.InchesToPoints(0.787401575)
.TopMargin = Application.InchesToPoints(0.984251969)
.BottomMargin = Application.InchesToPoints(0.984251969)
.HeaderMargin = Application.InchesToPoints(0.4921259845)
.FooterMargin = Application.InchesToPoints(0.4921259845)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA3
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintErrors = xlPrintErrorsDisplayed
End With
Range("A2").Select
'############################################################################################### _
'Datei speichern und schließen
'############################################################################################### _
Call list_sort
ActiveWorkbook.Save
ActiveWorkbook.Close
'############################################################################################### _
'Userform Fortschrittanzeige auf 100% setzen, 2 sek. warten und ausblenden
'############################################################################################### _
UserForm4.Label5.Caption = zz - 1
UserForm4.Label8.Width = 300
UserForm4.Label10.Caption = 100 & " %"
DoEvents
Application.Wait Now + TimeValue("00:00:02")
UserForm4.Hide
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.SheetsInNewWorkbook = 3
'############################################################################################### _
'Fehlerhafte CSV Dateien anzeigen, falls vorhanden
'############################################################################################### _
If Fehlerzähler = 1 Then
MsgBox Fehlerliste & vbCrLf & vbCrLf & "Datei wird im Projektverzeichnis ..\dpf\ als  _
fehlerhaft markiert!" _
& vbCrLf & "Bitte die entsprechende Streckendatei prüfen und die fehlerhafte Berechnung  _
erneut durchführen." _
& vbCrLf & "Die fehlerhafte Berechnung wurde nicht in die Verbrauchsübersicht_" & PROJEKT &  _
".xls eingetragen!", _
vbOKOnly & vbExclamation, "Es wurde eine Fehlerhafte CSV Datei gefunden!"
ElseIf Fehlerzähler > 1 Then
MsgBox Fehlerliste & vbCrLf & vbCrLf & "Dateien werden im Projektverzeichnis ..\dpf\ als  _
fehlerhaft markiert!" _
& vbCrLf & "Bitte die entsprechenden Streckendateien prüfen und die fehlerhaften  _
Berechnungen erneut durchführen." _
& vbCrLf & "Die fehlerhaften Berechnungen wurden nicht in die Verbrauchsübersicht_" &  _
PROJEKT & ".xls eingetragen!", _
vbOKOnly & vbExclamation, "Es wurden mehrere Fehlerhafte CSV Dateien gefunden!"
End If
End Sub

VG, Ralf
Anzeige
AW: Schleifendauer
21.10.2010 15:19:05
Ralf_P
Muss mich selbst verbessern,
"Application.enableevents = false ==> ist nicht gesetzt"
sollte es heißen.
AW: Schleifendauer
21.10.2010 16:15:43
Rudi
Hallo,
ich würde die Daten erst mal in ein Array einlesen, dann alles auf einmal in die neue Tabelle schreiben und anschließend die Tabelle formatieren. Weiterhin die Daten nicht per Query-Table holen, sondern per Input-Methode. Der Fortschrittsbalken frisst auch einiges.
Mal als Ansatz: 
Sub csv_to_xls()
Dim csvDatei As String
Dim csvName As String
Dim xlsName As String
Dim overview As String
Dim kbs As String
Dim strecke As String
Dim streckeNr As String
Dim Start As String
Dim ziel As String
Dim expr As String
Dim start_name As String
Dim ziel_name As String
Dim MFtrakt As String
Dim fahrzeug As String
Dim auslastung As String
Dim extension As String
Dim c As Integer
Dim i As Integer
Dim n As Long
Dim x As Integer
Dim z As Long
Dim zz As Long
Dim proz As Integer
Dim NUMMER As Variant
Dim Fehlerliste As String
Dim Fehlerzähler As Long
Dim arrDaten(), lngCounter As Long, arrTmp
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 2
'Zähler (z) für Gesamtanzahl der Dateien initialisieren
For i = 0 To ListAnzahl_csv - 1
If UserForm4.ListBox1.Selected(i) = True Then
z = z + 1
End If
Next
ReDim arrDaten(1 To z + 1, 1 To 16)
lngCounter = 1
UserForm4.Label4.Caption = z
'Zähler (zz) für verbleibende Anzahl der Dateien initialisieren
zz = z
'Label für Fortschrittanzeige einblenden
UserForm4.Label4.Visible = True
UserForm4.Label5.Visible = True
UserForm4.Label6.Visible = True
UserForm4.Label7.Visible = True
UserForm4.Label8.Visible = True
UserForm4.Label9.Visible = True
'Tabelle anlegen und Überschriften einfügen
arrDaten(1, 1).Value = "KBS"
arrDaten(1, 2).Value = "Strecke"
arrDaten(1, 3).Value = "Teilstrecken Nr."
arrDaten(1, 4).Value = "Start"
arrDaten(1, 5).Value = "Ziel"
arrDaten(1, 6).Value = "Start Name"
arrDaten(1, 7).Value = "Ziel Name"
arrDaten(1, 8).Value = "Haltemuster"
arrDaten(1, 9).Value = "MF-Trakt."
arrDaten(1, 10).Value = "Fahrzeug"
arrDaten(1, 11).Value = "Auslastung"
arrDaten(1, 12).Value = "Extension"
arrDaten(1, 13).Value = "Weg [m]"
arrDaten(1, 14).Value = "Zeit [hh:mm:ss]"
arrDaten(1, 15).Value = "Energie ab Fahrleitung [KWh]"
arrDaten(1, 16).Value = "Bremsenergie ab Fahrleitung [KWh]"
'Dateinamen erstellen und neue Tabelle speichern
overview = sPath & "dpf\" & "Verbrauchsübersicht_" & PROJEKT & ".xls"
ActiveWorkbook.SaveAs overview
'############################################################################################# _
## _
'Alle vorhandenen CSV auflisten und prüfen, welche ausgewählt wurden
'############################################################################################# _
## _
For i = 0 To ListAnzahl_csv - 1
If UserForm4.ListBox1.Selected(i) = True Then
csvDatei = sPath & "dpf\" & UserForm4.ListBox1.List(i) & ".csv"
If FileLen(csvDatei)  0 Then zz = zz - 1
'UserForm4.Label5.Caption = zz
proz = (100 - ((zz / z) * 100)) * 3
'UserForm4.Label8.Width = proz
'UserForm4.Label10.Caption = Round(proz / 3, 1) & " %"
'UserForm4.Label10.Caption = Int(proz / 3) & " %"
'DoEvents
'#######################################################################################  _
_
'Überschriften aus Dateinamen auslesen - unterscheiden nach
'Teilstrecke mit Nummer, Teilstrecke ohne Nummer, Hauptstrecke
'#######################################################################################  _
_
kbs = Mid(csvName, 6, 3)
NUMMER = Mid(csvName, 10, 1)
If NUMMER Like "#" Then
NUMMER = True
Else
NUMMER = False
End If
If NUMMER = True Then
strecke = "TeilStr"
streckeNr = Mid(csvName, 10, 2)
Start = Mid(csvName, 13, 4)
ziel = Mid(csvName, 18, 4)
expr = ""
MFtrakt = Mid(csvName, 23, 2)
fahrzeug = Mid(csvName, 25, 3)
auslastung = Mid(csvName, 28, 3)
extension = Mid(csvName, 32, 3)
ElseIf Mid(csvName, 10, 1) = "_" And Mid(csvName, 11, 1) = "_" Then
strecke = "TeilStr"
streckeNr = ""
Start = Mid(csvName, 13, 4)
ziel = Mid(csvName, 18, 4)
expr = ""
MFtrakt = Mid(csvName, 23, 2)
fahrzeug = Mid(csvName, 25, 3)
auslastung = Mid(csvName, 28, 3)
extension = Mid(csvName, 32, 3)
ElseIf Mid(csvName, 10, 1)  "_" And NUMMER = False Then
strecke = "HauptStr"
streckeNr = ""
Start = Mid(csvName, 10, 4)
ziel = Mid(csvName, 15, 4)
expr = Mid(csvName, 20, 2)
MFtrakt = Mid(csvName, 23, 2)
fahrzeug = Mid(csvName, 25, 3)
auslastung = Mid(csvName, 28, 3)
extension = Mid(csvName, 32, 3)
End If
'#########Daten in Array schreiben############
lngCounter = lngCounter + 1
arrTmp = DatenHolen(csvDatei)
arrDaten(lngCounter, 1).Value = kbs
arrDaten(lngCounter, 2).Value = strecke
arrDaten(lngCounter, 3).Value = streckeNr
arrDaten(lngCounter, 4).Value = Start
arrDaten(lngCounter, 5).Value = ziel
arrDaten(lngCounter, 6).Value = arrTmp(1)
arrDaten(lngCounter, 7).Value = arrTmp(2)
arrDaten(lngCounter, 8).Value = expr
arrDaten(lngCounter, 9).Value = MFtrakt
arrDaten(lngCounter, 10).Value = fahrzeug
arrDaten(lngCounter, 11).Value = auslastung
arrDaten(lngCounter, 12).Value = extension
arrDaten(lngCounter, 13).Value = arrTmp(3)
arrDaten(lngCounter, 14).Value = arrTmp(4)
arrDaten(lngCounter, 15).Value = Round(arrTmp(5), 2)
arrDaten(lngCounter, 16).Value = Round(arrTmp(6), 2)
End If
FEHLER:
Next
With Workbooks.Add.Sheets(1)
.Cells(1, 1).Resize(lngCounter, 16) = arrDaten
'noch die Formatierungen
End With
End Sub


Function DatenHolen(sDatei As String)
'Daten aus csv lesen
Dim myArr(1 To 6), arrTmp, sDaten
Open sDatei For Input As #1
sDaten = Split(Input(LOF(1), 1), vbCrLf)
Close #1
'1.Datenssatz
arrTmp = Split(sDaten(1), ";")
myArr(1) = arrTmp(0)
'letzter Datensatz
arrTmp = Split(sDaten(UBound(sDaten) - 1), ";")
myArr(2) = arrTmp(0)
myArr(3) = arrTmp(2)
myArr(4) = arrTmp(4) / 86400
myArr(5) = arrTmp(6)
myArr(6) = arrTmp(8)
DatenHolen = myArr
End Function

Genauer geht's nur mit ner Original-CSV.
Gruß
Rudi
Anzeige
AW: Schleifendauer
21.10.2010 16:33:04
Ralf_P
Hallo Rudi,
danke für den Input, werde das morgen mal testen.
Ansonsten kann ich die Original-xls und Original-csv nur an Privatmail weitergeben.
Wäre das möglich?
VG, Ralf
AW: Schleifendauer
22.10.2010 10:06:57
Ralf_P
Hallo Rudi,
das scrpit hängt sich auf bei
arrDaten(1, 1).Value = "KBS"
Laufzeitfehler 424 - Objekt erforderlich
VG, Ralf
AW: Schleifendauer
22.10.2010 11:24:09
Rudi
Hallo,
mein Fehler.
Lösche überall hinter arrDaten(..., ...) das .Value
Gruß
Rudi
AW: Schleifendauer
22.10.2010 12:42:50
Ralf_P
Hallo Rudi,
habe das .Value rausgenommen und noch die eine oder andere Kleinigkeit wie
"with Schleife ohne End With"
angepasst.
Es sind zwar noch einige Formatierungsfehler in der zu erstellenden Datei, aber die Durchlaufzeit ist rasant.
Bei 3000 csv von 19min42sec auf 17sec.
Bei 6000 csv von 1/2 Tag auf 46sec.
Das ist der Wahnsinn.
Ich muss mich wohl mehr mit den Arrays beschäftigen ;-)
Die restlichen Anpassungen werde ich hoffentlich alleine hinbekommen.
1000 Dank für Deine Unterstützung
Gruß Ralf
Anzeige
AW: Schleifendauer
22.10.2010 12:51:58
Rudi
Hallo,
schön, dass es klappt.
Es liegt aber nicht nur am Array, sondern daran, wie die csv gelesen werden. Das ist (glaube ich) erheblich schneller als die Query-Table (die ich noch nie benutzt habe).
Gruß
Rudi

Links zu Excel-Dialogen

Label ListBox

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige