AW: noch eine kleine Erweiterung Möglich ?
fcs
Hallo Eddie,
hier die modifizierte Hauptprozedur, die bei bestimmten Spalten einen 2. Trennstrich einfügt.
Gruß
Franz
Sub Text_Export()
Dim varDatei, wks As Worksheet, intAnzahlZeichen As Integer, bolLinks As Boolean
Dim lngZeile1 As Long, lngZeileE As Long, lngZ As Long
Dim lngZeile As Long, intFF As Integer, strText As String
Dim lngSpalte As Long, intI As Long, arrBreite() As Long, lngSpalte_mit_A As Long
Const strSep = " | " 'Trennzeichen zwischen Daten-Spalten in Tabellenabschnitten
Const strSep1 = " || " 'Trennzeichen nach Case ID und vor "_A"
Const strSep2 = " " 'Trennzeichen zwischen Daten-Spalten außerhalb Tabellenabschnitten
On Error GoTo Fehler
varDatei = Application.GetSaveAsFilename(InitialFileName:="TestExport.txt", _
Filefilter:="Text(*.txt), *.txt", _
Title:="Bitte Namen für Export-Datei wählen oder eingeben und speichern")
If varDatei False Then
Set wks = ActiveSheet
With wks
intFF = FreeFile()
Open varDatei For Output As #intFF
lngZeileLast = .UsedRange.Row + .UsedRange.Rows.Count - 1
For lngZeile = 1 To lngZeileLast
lngZeile1 = lngZeile
'nächste Tabelle suchen ("case id" steht in Spalte A)
Do
lngZeile = lngZeile + 1
If lngZeile > lngZeileLast Then Exit Do
Loop Until InStr(1, .Cells(lngZeile, 1).Value, "case id") > 0
lngZeileE = lngZeile - 1
'Nicht Tabellentexte in Datei schreiben
Do
strText = wks.Cells(lngZeile1, 1).Text
'ggf. Texte aus weiteren Spalten einlesen
If .Cells(lngZeile1, .Columns.Count).End(xlToLeft).Column > 1 Then
For lngSpalte = 2 To .Cells(lngZeile1, .Columns.Count).End(xlToLeft).Column
intAnzahlZeichen = Len(wks.Cells(lngZeile1, lngSpalte).Text)
strText = strText & strSep2 _
& LeerzeichenAuffuellen(strText:=wks.Cells(lngZeile1, _
lngSpalte).Text, intZeichen:=intAnzahlZeichen, bolLinks:=True)
Next
End If
Print #intFF, strText
lngZeile1 = lngZeile1 + 1
Loop Until lngZeile1 > lngZeileE
If lngZeileE = lngZeileLast Then Exit For
'Anfang Tabelle setzen
lngZeile1 = lngZeileE + 1
'Ende Tabelle suchen (nächste leere Zeile)
lngZeileE = lngZeile1 + 1
Do
lngZeile = lngZeile + 1
If lngZeile >= lngZeileLast Then Exit Do
Loop Until IsEmpty(.Cells(lngZeile, 1)) Or IsEmpty(.Cells(lngZeile, 2))
lngZeileE = lngZeile - 1
'Letzte Spalte in Titelzeile ermitteln
lngSpalteMax = .Cells(lngZeile1, .Columns.Count).End(xlToLeft).Column
ReDim arrBreite(1 To lngSpalteMax)
'Spalten Breiten ermitteln und in Array speichern
For lngSpalte = 1 To lngSpalteMax
For lngZ = lngZeile1 To lngZeileE
If LCase(.Cells(lngZ, lngSpalte).Text) = "remarks/comment" Then
arrBreite(lngSpalte) = 999
Exit For
Else
If Len(.Cells(lngZ, lngSpalte).Text) > arrBreite(lngSpalte) Then
arrBreite(lngSpalte) = Len(.Cells(lngZ, lngSpalte).Text)
End If
End If
Next
Next
'Spalte mit Titel mit "_A" ermitteln
lngSpalte_mit_A = 999
For lngSpalte = 1 To lngSpalteMax
If InStr(.Cells(lngZeile1, lngSpalte).Text, "_A") > 0 Then
lngSpalte_mit_A = lngSpalte
Exit For
End If
Next
'Zeilen des Tabellenbereichs einlesen
For lngZ = lngZeile1 To lngZeileE
'Wert aus 1. Spalte einlesen
intAnzahlZeichen = arrBreite(1)
strText = LeerzeichenAuffuellen(strText:=.Cells(lngZ, 1).Text, _
intZeichen:=intAnzahlZeichen, bolLinks:=IsNumeric(.Cells(lngZ, 1).Text))
'Werte aus restlichen Spalten einlesen
For lngSpalte = 2 To lngSpalteMax
If arrBreite(lngSpalte) 999 Then
intAnzahlZeichen = arrBreite(lngSpalte)
Else
intAnzahlZeichen = Len(wks.Cells(lngZ, lngSpalte).Text)
End If
bolLinks = IsNumeric(.Cells(lngZeile, 1).Text)
Select Case lngSpalte
Case 2, lngSpalte_mit_A
'Trennzeichen = " || "
strText = strText & strSep1 _
& LeerzeichenAuffuellen(strText:=wks.Cells(lngZ, _
lngSpalte).Text, intZeichen:=intAnzahlZeichen, bolLinks:=bolLinks)
Case Else
'Trennzeichen = " | "
strText = strText & strSep _
& LeerzeichenAuffuellen(strText:=wks.Cells(lngZ, _
lngSpalte).Text, intZeichen:=intAnzahlZeichen, bolLinks:=bolLinks)
End Select
Next
'Zeile in Text-Datei schreiben
Print #intFF, strText
If lngZ = lngZeile1 Then
'Zeile mit "-" nach 1. Zeile der Tabelle einfügen
'Gesamt-Anzahl Zeichen in den Spalten ermitteln
intI = 0
intI = arrBreite(1)
For lngSpalte = 2 To lngSpalteMax
If arrBreite(lngSpalte) = 999 Then
intI = intI + Len(strSep) + Len("remarks/comment")
Else
intI = intI + Len(strSep) + arrBreite(lngSpalte)
End If
Next
'zusätzliche Zeichen für Sonderlänge 1. Trennzeichen und vor "_A" in tabelle
intI = intI + (Len(strSep1) - Len(strSep))
If lngSpalte_mit_A 999 Then
intI = intI + (Len(strSep1) - Len(strSep))
End If
strText = String(intI, "-")
Print #intFF, strText
End If
Next
lngZeile = lngZeileE
Next
Close #intFF
End With
End If
Fehler:
If Err.Number 0 Then
Select Case Err.Number
Case 999 '
Case Else
MsgBox "Fehler: " & Err.Number & vbLf & Err.Description
End Select
End If
End Sub