Hallo Andreas,
so sollte es funktionieren
Sub createCsgFiles()
Dim fso As New Scripting.FileSystemObject
Dim ts As Scripting.TextStream
Dim myArr() As String
Dim r As Range
Dim i As Integer
Dim rng As Range
Dim s As String
Dim intLastRow As Integer
Dim strFilename As String
'**********
'* WICHTIG: Unter Verweise die Bibliothek: Microsft Scripting Runtime aktivieren !!!
'**********
'*********
'* Die zu übertragenden Texte stehen in den Spalten 1-7, der Name der Datei in Spalte 8
'*********
With Sheets("Tabelle2")
'Letzte verwendete Zeile festlegen
intLastRow = .Cells(Rows.Count, 1).End(xlUp).row
'verwendeten Bereich festlegen
Set rng = .Range(.Cells(1, 1), .Cells(intLastRow, 8))
End With
For Each r In rng
'Speichern der Texte in einem Array
For i = 0 To 6
ReDim Preserve myArr(i)
myArr(i) = subString(r.Offset(0, 0).Value)
Next i
'Trennung der Begriffe durch ein Tab
s = Join(myArr, vbTab)
'Festlegen des Dateinamens
strFilename = r.Offset(0, 7).Value
'Speichern der Dateien auf dem Desktop
Set ts = fso.OpenTextFile(Environ("UserProfile") & "\desktop\" & strFilename & ".csg", ForAppending, True)
'Schreiben der Texte in die .csg-Datei
ts.WriteLine s
'Schließen der .csg-Datei
ts.Close
Next r
End Sub
Function subString(ByVal strText As String) As String
'Funktion zum Zerlegen des Strings. Der Text innerhalb der Anführungszeichen wird separiert
subString = Mid(strText, InStr(1, strText, Chr(34)) + 1, Len(strText) - InStr(1, strText, Chr(34)) - 1)
End Function
Bei Fragen gerne melden.
Viele Grüße
Kai
|