AW: zeig doch mal den Code. o.T.
11.03.2009 22:56:19
Josef
Hallo Eric,
so, ich habe den Code angepasst und aufgeräumt, war ja gruselig;-)
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Public Sub CSVImport_01()
' CSV oder TXT einlesen auf mehreren Tabellen, 65536 Zeilen begrenzt durch Excel, dadurch ggf. _
mehrere Blätter, CSV hat bis zu 200.000 Zeilen
Dim strValues() As String
Dim FileName As Variant, ResultStr As String
Dim lngRow As Long, intSheet As Integer, FileNum As Integer, lngIndex As Long
Dim str As String, s_Datum As String, s_Zeit As String
Dim objWB As Workbook, objWS As Worksheet
Const LWCSV = "F:\"
Const PFADCSV = "F:\_umsetzen\_csv"
Const PfadSICH = "F:\_UMSETZEN\_AUSGANG\"
On Error GoTo ErrExit
GMS
ChDrive LWCSV
ChDir PFADCSV
FileName = Application.GetOpenFilename("Textdateien " _
& "(*.txt; *.csv),*.txt; *.csv", _
Title:=" CSV oder TXT Datei zum Öffnen auswählen", MultiSelect:=True)
If IsArray(FileName) Then
Set objWB = Workbooks.Add(xlWBATWorksheet)
Set objWS = objWB.Sheets(1)
lngRow = 1
intSheet = 1
For lngIndex = LBound(FileName) To UBound(FileName)
Erase strValues
Redim strValues(1 To Rows.Count, 1 To 1)
If lngIndex > LBound(FileName) Then
Set objWS = objWB.Worksheets.Add(after:=objWB.Worksheets(objWB.Worksheets.Count))
lngRow = 1
intSheet = intSheet + 1
End If
Application.StatusBar = "Blatt " & intSheet & " wird eingelesen"
FileNum = FreeFile()
Open FileName(lngIndex) For Input As #FileNum
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 < Rows.Count Then
lngRow = lngRow + 1
Else
objWS.Range("A1:A" & Rows.Count) = strValues
Set objWS = objWB.Worksheets.Add(after:=objWB.Worksheets(objWB.Worksheets.Count))
lngRow = 1
intSheet = intSheet + 1
Erase strValues
Redim strValues(1 To Rows.Count, 1 To 1)
Application.StatusBar = "Blatt " & intSheet & " wird eingelesen"
End If
Loop
Close #FileNum
objWS.Range("A1:A" & Rows.Count) = strValues
Next
If MsgBox("Sollen die eingelesenen Daten auf Spalten verteilt werden?", _
vbYesNo, "Text in Spalten") = vbNo Then GoTo ErrExit
intSheet = 0
Set objWS = Nothing
For Each objWS In objWB.Worksheets
intSheet = intSheet + 1
Application.StatusBar = "Daten von Blatt " & intSheet _
& " werden bearbeitet"
With objWS
.Activate
.Range("A:A").TextToColumns Destination:=.Range("A1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, _
Semicolon:=True, _
Comma:=False, _
Space:=False, _
Other:=False
With .UsedRange.Cells.Font
.Name = "Arial"
.Size = 8
.ThemeColor = xlThemeColorLight1
End With
.UsedRange.Columns.AutoFit
.Range("A1").Select
End With
Next
s_Datum = Date
s_Zeit = Time
s_Datum = Application.Substitute(s_Datum, ".", "")
str = PfadSICH & objWB.Name
objWB.SaveAs FileName:=str & s_Datum & "_" & _
Format(s_Zeit, "hhmmss") & ".xls", FileFormat:= _
xlNormal, Password:="", writerespassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=True
objWB.Close
Application.StatusBar = "Fertig"
End If
ErrExit:
With Err
If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
.Description & vbLf & vbLf & "In Prozedur (CSVImport_01) in Modul Modul1", _
vbExclamation, "Fehler in Modul1 / CSVImport_01"
End With
GMS True
Application.StatusBar = False
Set objWB = Nothing
Set objWS = Nothing
End Sub
Public Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
End Sub
Gruß Sepp