AW: mir stellt sich da die Frage ...
29.01.2016 07:30:34
Larissa
Hi,
dann jetzt noch einmal ein neuer Versuch:
;per Fax,322013,,LIE15/149317;
Onlineshop,192972,,LIE15/149321,LIE15/149321;
Onlineshop,192992,,LIE15/149322,LIE15/149322;
So sieht der Datensatz aus, aber ohne Absätze (die habe ich manuell eingeführt, zur besseren Leserlichkeit.
Mein Ansatz bisher:
Public Sub datachoose()
Dim FileName As String
Dim FilePath As String
FilePath = Application.GetOpenFilename("Excel-Dateien (*.txt), *.txt")
If FilePath "Falsch" Then
FileName = Dateiname(FilePath)
Call genwkb(FileName, FilePath)
Else
MsgBox "Bitte eine Datei auswählen !", vbOKOnly + vbCritical, "Excel-Tool-Fehler"
End If
End Sub
Sub genwkb(ByVal zWkb As String, ByVal FilePath As String)
Dim xlsName As String
Dim ct As Integer
Dim zWkb2 As String
zWkb2 = Application.ThisWorkbook.Name
ct = 1
Application.Workbooks.Add
Cells.Select
Selection.NumberFormat = "@"
xlsName = zWkb & ActiveWorkbook.Name & ".xls"
ActiveWorkbook.SaveAs (xlsName)
Call txt2xls(FilePath, xlsName)
End Sub
Sub txt2xls(sText As String, sWkb As String)
Dim Buffer As String, arrTmp
Dim wksZiel As Worksheet
Dim lRow As Long
Set wksZiel = Workbooks(sWkb).Sheets(1)
Open sText For Input As #1
Do While Not EOF(1)
lRow = lRow + 1
Line Input #1, Buffer
arrTmp = Split(Mid(Trim(Buffer), 2), ",")
wksZiel.Cells(lRow, 1).Resize(, UBound(arrTmp) + 1) = arrTmp
Loop
Close #1
End Sub
Sub txttoxls()
Dim txt As String
Dim Buffer As String
Dim acLine As Long
Dim acCol As Long
Dim zWkb2 As String
Dim xlsName As String
Application.Workbooks.Add
Cells.Select
Selection.NumberFormat = "@"
xlsName = zWkb & ActiveWorkbook.Name & ".xls"
ActiveWorkbook.SaveAs (xlsName)
zWkb2 = Application.ActiveWorkbook.Name
acLine = 0
acRow = 1
txt = Application.GetOpenFilename("Excel-Dateien (*.txt), *.txt")
Open txt For Input As 1
While Not EOF(1)
Buffer = Input(1, #1)
If Buffer = ";" Then
acLine = acLine + 1
acRow = 1
ElseIf Buffer = "," Then
acRow = acRow + 1
Else
Application.Workbooks(zWkb2).Sheets(1).Cells(acLine, acRow).Value = _
Application.Workbooks(zWkb2).Sheets(1).Cells(acLine, acRow).Value & _
Buffer
'Application.Workbooks(zWkb).Sheets(1).Cells(1, 2).Value = "tesr"
End If
Wend
Close #1
ActiveWorkbook.Save
End Sub
Function Dateiname(Pfad As String)
Dim x As Long
If InStr(Pfad, "\") Then
For x = Len(Pfad) To 1 Step -1
If Mid(Pfad, x, 1) = "\" Then
S = Mid(Pfad, x + 1)
Exit For
End If
Next x
ElseIf InStr(Pfad, ":") = 2 Then
S = Mid(Pfad, 3)
Else
S = Pfad
End If
Dateiname = S
End Function
In der Excel-Datei wird per Button die Methode "datachoose" aufgerufen. Mit diesem Makro oder der von Excel bereitgestellten Funktion "Daten aus Text" stehen alle Datensätze in A1, B1, C1, D1, etc. Die Daten sollen aber wie oben untereinander stehen.
Ich hoffe, dass das Beispiel jetzt deutlicher geworden ist und Entschuldigung für den chaotischen ersten Beitrag.