Tipp´s für Performance

Sub Auslesen() Dim file As Integer Dim Kennung As String Dim Zielpfad As String Dim Zieldatei As String Dim UW As String Dim var As Range Dim n As Long With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False End With Kennung = "1" Zieldatei = Dir("Dateiname") Zielpfad = "Dateipfad" k = 1 With Worksheets("Liste") .Columns("A").Value = .Columns("G").Value End With Do While Zielpfad <> "" With Worksheets("Liste") .Range("C3:E200").ClearContents .Range("M:M").ClearContents End With Open Zielpfad & Zieldatei For Input As #1 Do While Not EOF(1) Line Input #1, Zeilen file = InStr(Zeilen, Kennung) If file > 0 Then With Worksheets("Liste") .Cells(Rows.Count, 3).End(xlUp).Offset(1) = Mid$(Zeilen, 19, 13) .Cells(Rows.Count, 4).End(xlUp).Offset(1) = Mid$(Zeilen, 54, 6) .Cells(Rows.Count, 5).End(xlUp).Offset(1) = Mid$(Zeilen, 62, 6) End With End If Loop Close #1 Worksheets("Liste").Sort.SortFields.Clear Worksheets("Liste").Sort.SortFields.Add Key:=Range("C3"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Liste").Sort .SetRange Range("C3:E196") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Sheets("Liste").Range("K3:N76").Calculate m = 0 For i = 3 To 196 If Cells(i, 1) <> Cells(i, 3) Then UW = Left(Range(Cells(i, 1), Cells(i, 1)), 4) With Worksheets("Liste") Set var = .Range("J3:J76").Find(UW, LookIn:=xlValues, lookat:=xlWhole) If Not var Is Nothing Then n = var.Row Else MsgBox "Fehler in Find.Funktion bei Zeile " & i End If If .Cells(n, 14) = 0 Then .Range(Cells(i, 3), Cells(i, 5)).Insert Shift:=xlDown .Cells(n, 13) = 1 .Range("N3:N76").Calculate Else .Cells(i, 1) = .Cells(i, 3) m = 1 End If End With End If Next Worksheets("Liste").Sort.SortFields.Clear Worksheets("Liste").Sort.SortFields.Add Key:=Range("A3"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With Worksheets("Liste").Sort .SetRange Range("A3:A196") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With If m = 1 Then Worksheets("Liste").Range("C2:E196").Copy Worksheets("Tabelle").Cells(Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial Transpose:= _ True Worksheets("Tabelle").Cells(2 * k, 1) = Left$(Zieldatei, 13) Worksheets("Tabelle").Cells(2 * k + 1, 1) = Left$(Zieldatei, 13) Else Worksheets("Liste").Range("D2:E196").Copy Worksheets("Tabelle").Cells(Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial Transpose:= _ True Worksheets("Tabelle").Cells(2 * k, 1) = Left$(Zieldatei, 13) Worksheets("Tabelle").Cells(2 * k + 1, 1) = Left$(Zieldatei, 13) End If Zieldatei = Dir k = k + 1 Loop With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Dim objListe As Object, vArr(), oListe, iCounter As Integer Set objListe = CreateObject("scripting.dictionary") ' weiterer Code Do While Zielpfad <> "" objListe.RemoveAll With Worksheets("Liste") .Range("C3:E200").ClearContents .Range("M:M").ClearContents End With Open Zielpfad & Zieldatei For Input As #1 Do While Not EOF(1) Line Input #1, Zeilen file = InStr(Zeilen, Kennung) If file > 0 Then objListe(objListe.Count + 1) = Array(Mid$(Zeilen, 19, 13), Mid$(Zeilen, 54, _ 6), Mid$(Zeilen, 62, 6)) End If Loop Close #1 ReDim vArr(1 To objListe.Count, 1 To 3) iCounter = 0 For Each oListe In objListe iCounter = iCounter + 1 vArr(iCounter, 1) = objListe(oListe)(0) vArr(iCounter, 2) = objListe(oListe)(1) vArr(iCounter, 3) = objListe(oListe)(2) Next oListe Worksheets("Liste").Cells(Rows.Count, 3).Offset(1).Resize(UBound(vArr), 3) = vArr

Hi,
hier noch ein Vorschlag, der das macht, was Daniel angedeutet hat: die ganze Datei in einem Rutsch lesen und verwurschteln:

Sub TextLesenUndSchreiben(Blatt$, Datei$, Zeile&, nurWenn$)
Dim DNr As Long
Dim sIn As String, aIn, aOut()
Dim iIn&, iOut&
DNr = FreeFile
Open Datei For Input As #DNr
sIn = Input(LOF(DNr), DNr)
Close #DNr
aIn = Split(sIn, vbCrLf) ' #13,#10
sIn = "" ' vielleicht?
If UBound(aIn) >= 0 Then
ReDim aOut(1 To UBound(aIn) + 1, 1 To 3)
For iIn = 0 To UBound(aIn)
If InStr(aIn(iIn), nurWenn) > 0 Then
iOut = iOut + 1
aOut(iOut, 1) = Mid$(aIn(iIn), 19, 13)
aOut(iOut, 2) = Mid$(aIn(iIn), 54, 6)
aOut(iOut, 3) = Mid$(aIn(iIn), 62, 6)
End If
Next
Sheets(Blatt).Range("C" & Zeile).Resize(iOut, 3) = aOut
End If ' else: evtl. Fehlerbehandlung oder doch als Function mit as boolean
End Sub
Sub Aufruf()
Dim shName$, Dateiname$
Dim z&
Dim t0 As Single
shName = "Liste"
Dateiname = "C:\A_Herber\A_Std\TextImport_Test.txt"
z = Sheets(shName).Range("C" & Rows.Count).End(xlUp).Row + 1
t0 = Timer
Call TextLesenUndSchreiben(shName, Dateiname, z, "1")
MsgBox "Eingelesen in " & Timer - t0 & " Sekunden"
End Sub

Den Aufruf (unten die Zeile mit dem Call) kannst Du in Deinen Code an entsprechender Stelle einfügen.
Ich hab's mal mit einer Testdatei mit 2500 Zeilen getestet: es geht in Sekundenbruchteilen (und das bei meiner Hardware).
Allerdings... Wenn ich mir ansehe, was danach noch passiert: Gerade die For-Schleife ist zeitraubend, und da insbesondere das

.Range(Cells(i, 3), Cells(i, 5)).Insert Shift:=xlDown

Man könnte die ganze Vergleicherei gleich im "Array" machen: if aOut(iOut, 1) = aOut(iOut, 3)
aber dann müßte man wissen, was für Berechnungen in Spalte N passieren.
Rudis Code enthält ja ein "Dictionary", das die .find in Deiner Schleife deutlich beschleunigen würde:
Du suchst ja immer im gleichen Bereich (J) nach Werten, die sich Lauf des Makros anscheinend nicht ändern (J wird ja nicht .calculated, nur N).
Das Ganze mal am Stück:

Option Explicit
Sub Auslesen()
Dim file As Integer
Dim Kennung As String
Dim Zielpfad As String
Dim Zieldatei As String
Dim UW As String
Dim var As Range
Dim n As Long, k As Long, m As Long, i As Long
' bitte mit option explicit und alles sauber Dim-en!
Dim o As Object
Set o = CreateObject("scripting.dictionary")
With Worksheets("Liste")
For n = 3 To 76: o(.Range("J" & n)) = n: Next
End With
' Damit sind alle Einträge von J3:J76 im Dict.
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Kennung = "1"
Zieldatei = Dir("Dateiname")
Zielpfad = "Dateipfad"
k = 1
With Worksheets("Liste")
.Columns("A").Value = .Columns("G").Value
End With
Do While Zielpfad <> ""
With Worksheets("Liste")
.Range("C3:E200").ClearContents
.Range("M:M").ClearContents
End With
n = Sheets("Liste").Range("C" & Rows.Count).End(xlUp).Row + 1
Call TextLesenUndSchreiben("Liste", Zielpfad & Zieldatei, n, Kennung)
'         Open Zielpfad & Zieldatei For Input As #1
'             Do While Not EOF(1)
'                 Line Input #1, Zeilen
'                     file = InStr(Zeilen, Kennung)
'                     If file > 0 Then
'                         With Worksheets("Liste")
'                         .Cells(Rows.Count, 3).End(xlUp).Offset(1) = Mid$(Zeilen, 19, 13)
'                         .Cells(Rows.Count, 4).End(xlUp).Offset(1) = Mid$(Zeilen, 54, 6)
'                         .Cells(Rows.Count, 5).End(xlUp).Offset(1) = Mid$(Zeilen, 62, 6)
'                         End With
'                     End If
'                 Loop
'             Close #1
Worksheets("Liste").Sort.SortFields.Clear
Worksheets("Liste").Sort.SortFields.Add Key:=Range("C3"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Liste").Sort
.SetRange Range("C3:E196")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets("Liste").Range("K3:N76").Calculate
m = 0
For i = 3 To 196
If Cells(i, 1) <> Cells(i, 3) Then
UW = Left(Range(Cells(i, 1), Cells(i, 1)), 4)
With Worksheets("Liste")
''               Set var = .Range("J3:J76").Find(UW, LookIn:=xlValues, lookat:=xlWhole)
''                   If Not var Is Nothing Then
''                       n = var.Row
''                     Else
''                        MsgBox "Fehler in Find.Funktion bei Zeile  " & i
''              ' hier aufpassen! Wenn n nicht gefunden, wird das *****
''              ' vorherige n unten genommen: ist das erwünscht? ******
''                   End If
' .find ersetzt durch Dictionary-Abfrage:
If o.exists(UW) Then n = o(UW) Else MsgBox "nicht vorhanden"
' das war's auch schon
If .Cells(n, 14) = 0 Then
.Range(Cells(i, 3), Cells(i, 5)).Insert Shift:=xlDown
.Cells(n, 13) = 1
.Range("N3:N76").Calculate
Else
.Cells(i, 1) = .Cells(i, 3)
m = 1
End If
End With
End If
Next
Worksheets("Liste").Sort.SortFields.Clear
Worksheets("Liste").Sort.SortFields.Add Key:=Range("A3"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Worksheets("Liste").Sort
.SetRange Range("A3:A196")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
If m = 1 Then
Worksheets("Liste").Range("C2:E196").Copy
Worksheets("Tabelle").Cells(Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial  _
Transpose:= _
True
Worksheets("Tabelle").Cells(2 * k, 1) = Left$(Zieldatei, 13)
Worksheets("Tabelle").Cells(2 * k + 1, 1) = Left$(Zieldatei, 13)
Else
Worksheets("Liste").Range("D2:E196").Copy
Worksheets("Tabelle").Cells(Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial  _
Transpose:= _
True
Worksheets("Tabelle").Cells(2 * k, 1) = Left$(Zieldatei, 13)
Worksheets("Tabelle").Cells(2 * k + 1, 1) = Left$(Zieldatei, 13)
End If
Zieldatei = Dir
k = k + 1
Loop
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub

Schöne Grüße,
Michael

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread