AW: Daten aus CSV-Datei per Makro kopieren.
08.03.2005 19:58:33
Josef
Hallo!
Ein kleiner Ansatz:
vor kurzem hier im Forum erhalten.
Option Explicit
Option Base 1
Sub Read_Large_File_2()
Dim FileName As String
Dim FileNum As Integer
Dim ResultStr As String
Dim wsSheet As Worksheet
Dim strValues() As String
Dim lngRows As Long
Dim lngRow As Long
Dim intSheet As Integer
Dim intCounter As Integer
FileName = Application.GetOpenFilename("Textdateien " & _
"(*.txt; *.csv),*.txt; *.csv")
If FileName = "" Or FileName = "Falsch" Then Exit Sub
FileNum = FreeFile()
Open FileName For Input As #FileNum
Application.ScreenUpdating = False
Workbooks.Add template:=xlWorksheet
lngRows = ActiveSheet.Rows.Count
lngRow = 1
intSheet = 1
ReDim strValues(lngRows, 1)
Application.StatusBar = "Blatt " & intSheet & " wird eingelesen"
Do While Seek(FileNum) <= LOF(FileNum)
Line Input #FileNum, ResultStr
If Left(ResultStr, 1) = "=" Then
strValues(lngRow, 1) = "'" & ResultStr
Else
strValues(lngRow, 1) = ResultStr
End If
If lngRow < lngRows Then
lngRow = lngRow + 1
Else
ActiveSheet.Range("A1:A" & lngRows) = strValues
ActiveWorkbook.Worksheets.Add after:=Worksheets(Worksheets.Count)
ReDim strValues(lngRows, 1)
lngRow = 1
intSheet = intSheet + 1
Application.StatusBar = "Blatt " & intSheet & " wird eingelesen"
End If
Loop
Close
ActiveSheet.Range("A1:A" & lngRows) = strValues
If MsgBox("Sollen die eingelesenen Daten auf Spalten verteilt werden?", _
vbYesNo, "Text in Spalten") = vbNo Then
Application.ScreenUpdating = True
Application.StatusBar = "Fertig"
Exit Sub
End If
intSheet = 0
For Each wsSheet In ActiveWorkbook.Worksheets
intSheet = intSheet + 1
Application.StatusBar = "Daten von Blatt " & intSheet _
& " werden bearbeitet"
With wsSheet
.Range("A:A").TextToColumns Destination:=.Range("A1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, _
Semicolon:=True, _
Comma:=False, _
Space:=False, _
Other:=False
End With
Next wsSheet
Application.ScreenUpdating = True
Application.StatusBar = "Fertig"
End Sub
