AW: Textdatei Ex und Import
24.03.2020 14:43:39
fcs
Hallo Olga,
was für Zeiten erwartest du denn?
Auf meinem schon etwas betagten PC braucht das Makro in deiner Testdatei für 1000 Zeilen ca, 5,5 Sekunden.
Solltest du in deiner Datei noch irgendwelche Formeln haben, die mit den importierten Daten rechnen, dann muss zusätzlich der Berechnungsmodus auf manuell gesetzt werden.
Eine weitere Bremse kann sein, wenn die Datei auf Microsoft-OneDrive gespeichert ist und automatisches Speichern aktiv ist. Hier ist es ratsam das automatische Speichern der Datei zu deaktivieren.
Ich hab das Makro jetzt mal umgeschrieben, so dass die Daten über ein Daten-Array aufbereitet werden und nicht über viele Zugriffe auf einzelne Zellen. Da sinkt die Zeit zur Ausführung des Makros auf unter 1 Sekunde.
LG
Franz
Sub Import_txt()
Dim lRow As Long, lCol As Integer
Dim sText As String
Dim arrData
Dim tStart, tStop
tStart = VBA.Timer
'Textdatei
sFile = ThisWorkbook.Path & "\Angebot.txt"
'Fehlermeldung falls nicht vorhanden
If Dir(sFile) = "" Then
MsgBox "Datei wurde nicht gefunden" & vbLf & "oder verschoben!"
Exit Sub
End If
Close 'alle offenen Dateien schliessen
'Txt öffnen und Datensätze zählen
Open sFile For Input As #1
lRow = 0
Do Until EOF(1)
Line Input #1, sText
lRow = lRow + 1
Loop
Close #1
'Array für die Daten dimensionieren
ReDim arrData(1 To lRow, 1 To 9)
'Txt öffnen und Daten einlesen
Open sFile For Input As #1
lRow = 1 'erste Zeile
lCol = 1 'erste Spalte
Do Until EOF(1)
Line Input #1, sText
Do While InStr(sText, ";")
arrData(lRow, lCol) = Left(sText, InStr(sText, ";") - 1)
sText = Right(sText, Len(sText) - InStr(sText, ";"))
lCol = lCol + 1
Loop
arrData(lRow, lCol) = sText
lRow = lRow + 1
lCol = 1
Loop
Close #1
'Zahlenwerte formatieren
For lCol = 1 To 9
Select Case lCol
Case 2, 5, 6
For lRow = 2 To UBound(arrData, 1)
arrData(lRow, lCol) = fncZahl(sZahl:=arrData(lRow, lCol), str1000er:=".", _
strDezimal:=",")
Next
End Select
Next
'Werte aus Array ins Tabellenblatt übertragen
Application.ScreenUpdating = False
With Sheets("Angebot")
.Cells(1, 9).Resize(UBound(arrData, 1), UBound(arrData, 2)) = arrData
End With
Application.ScreenUpdating = True
tStop = VBA.Timer
MsgBox "Fertig" & vbLf & "Zeit: " & tStop - tStart
End Sub