|
Hallo Andreas,
sorry, in der ersten Version war noch ein kleiner Fehler. Nun funktioniert es, wie gewünscht:
Sub createCsgFiles()
Dim fso As New Scripting.FileSystemObject
Dim ts As Scripting.TextStream
Dim myArr() As String
Dim r As Integer
Dim i As Integer
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
End With
For r = 1 To intLastRow
'Speichern der Begriffe in einem Array
For i = 0 To 6
ReDim Preserve myArr(i)
myArr(i) = subString(Sheets("Tabelle2").Cells(r, i + 1).Value)
Next i
'Trennung der Begriffe durch ein Tab
s = Join(myArr, vbTab)
'Festlegen des Dateinamens
strFilename = Sheets("Tabelle2").Cells(r, 8).Value
'Speichern der Dateien auf dem Desktop
Set ts = fso.OpenTextFile(Environ("UserProfile") & "\desktop\" & strFilename & ".csg", ForAppending, True)
'Schreiben der Begriffe 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
Viele Grüße
Kai
|