Beim Code versuch mal:
Option Explicit
Sub textdateien_uebernehmen()
Dim lngLaufZahl As Long
Dim strDateiNamen As Variant
Dim trgWB As Excel.Workbook
Dim tmpWB As Excel.Workbook
Dim trgWBName As String
Dim bslashPos As Integer
Dim shName As String
strDateiNamen = Application.GetOpenFilename("Text-Dateien(*.txt*),*.txt*", MultiSelect:=True)
If IsArray(strDateiNamen) Then
For lngLaufZahl = LBound(strDateiNamen) To UBound(strDateiNamen)
If lngLaufZahl = LBound(strDateiNamen) Then
Set trgWB = Workbooks.Open(Filename:=strDateiNamen(lngLaufZahl))
trgWB.Sheets(1).UsedRange.Columns("A").Select
'Hier das Trennzeichen ggf. ändern und das Format der einzelnen Spalten als Array definieren
Selection.TextToColumns DataType:=xlDelimited, textqualifier:=xlTextQualifierDoubleQuote, semicolon:=True
For bslashPos = Len(strDateiNamen(lngLaufZahl)) To 1
If Mid(strDateiNamen(lngLaufZahl), bslashPos, 1) = "\" Then Exit For
Next bslashPos
shName = strDateiNamen(lngLaufZahl)
shName = Right(shName, bslashPos - 1)
shName = Left(shName, Len(shName) - 4)
trgWB.Sheets(1).Name = shName
trgWBName = Application.GetSaveAsFilename(, "Excel-Arbeitsmappe (*.xls),*.xls")
trgWB.SaveAs trgWBName, xlWorkbookNormal
Else
Set tmpWB = Workbooks.Open(Filename:=strDateiNamen(lngLaufZahl))
tmpWB.Sheets(1).UsedRange.Columns("A").Select
Selection.TextToColumns DataType:=xlDelimited, textqualifier:=xlTextQualifierDoubleQuote, semicolon:=True
For bslashPos = Len(strDateiNamen(lngLaufZahl)) To 1
If Mid(strDateiNamen(lngLaufZahl), bslashPos, 1) = "\" Then Exit For
Next bslashPos
shName = strDateiNamen(lngLaufZahl)
shName = Right(shName, bslashPos - 1)
shName = Left(shName, Len(shName) - 4)
tmpWB.Sheets(1).Name = shName
tmpWB.Sheets(1).Copy After:=Workbooks(trgWBName).Sheets(trgWB.Sheets.Count)
trgWB.Save
tmpWB.Close False
Set tmpWB = Nothing
End If
Next lngLaufZahl
Else
Set trgWB = Workbooks.Open(Filename:=strDateiNamen)
trgWB.Sheets(1).UsedRange.Columns("A").Select
Selection.TextToColumns DataType:=xlDelimited, textqualifier:=xlTextQualifierDoubleQuote, semicolon:=True
For bslashPos = Len(strDateiNamen) To 1
If Mid(strDateiNamen, bslashPos, 1) = "\" Then Exit For
Next bslashPos
shName = strDateiNamen
shName = Right(shName, bslashPos - 1)
shName = Left(shName, Len(shName) - 4)
trgWB.Sheets(1).Name = shName
trgWBName = Application.GetSaveAsFilename(, "Excel-Arbeitsmappe (*.xls),*.xls")
trgWB.SaveAs trgWBName, xlWorkbookNormal
End If
Set trgWB = Nothing
End Sub
Was das Trennzeichen betrifft: Hier wird davon ausgegangen, daß der Strichpunkt (Semicolon) als Trennzeichen dient. Wenn das nicht der Fall ist, müßtest Du "semicolon:=True" ersetzen. Bei
-
Leerzeichen durch space:=True
-
Komma durch comma:=True
-
Tabulator durch tab:=True
Die einzelnen Spalten ließen sich vorab als bestimmtes Format definieren:
-
xlGeneralFormat. Allgemein = 0 |
xlTextFormat. Text = 1
xlMDYFormat. Datum im Format MTJ = 2
xlDMYFormat. Datum im Format TMJ = 3
xlYMDFormat. Datum im Format JMT = 4
xlMYDFormat. Datum im Format MJT = 5
xlDYMFormat. Datum im Format TJM = 6
xlYDMFormat. Datum im Format JTM = 7
xlEMDFormat. Datum im EMD-Format = 8
xlSkipColumn. Spalte überspringen = 9
|
Die Werte dieser Formate können durch die Integer 0 bis 9 ersetzt werden. Wenn Du also z.B. hinter "semicolon:=True" (wenn Semikolon Dein Trennzeichen ist) einfügst:
FieldInfo:=Array(Array(3, 9), Array(1, 4))
dann wird die Spalte 3 gelöscht (Array(3, 9)) und die Spalte 1 als Datum im Format JJJJ-MM-TT formatiert (Array(1, 4)). Alle anderen Spalten werden im Standardformat übernommen. Textformat für Spalte 2 wäre z.B. Array(2, 1). Wenn Du das nicht brauhst, dann mußt Du auch keine FieldInfo angeben.
Severus
|