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
strText = strText & strSep1 _
& LeerzeichenAuffuellen(strText:=wks.Cells(lngZ, _
lngSpalte).Text, intZeichen:=intAnzahlZeichen, bolLinks:=bolLinks)
Case Else
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
Sub Text_Export_Schritte()
Dim varDatei, wks As Worksheet, intAnzahlZeichen As Integer
Dim lngZeileLast As Long, lngSpalteMax As Long
Dim lngZeile As Long, intFF As Integer, strText As String
Dim lngSpalte As Long, arrBreite() As Long
Const strSep = "||" 'Trennzeichen zwischen Daten-Spalten
Const lngStartZeile = 10 'Zeile ab der Text-Datei erzeugt werden soll '#####
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
'Letzte Spalte in Titelzeile ermitteln
lngSpalteMax = .Cells(lngStartZeile, .Columns.Count).End(xlToLeft).Column '#####
ReDim arrBreite(1 To lngSpalteMax)
'Spalten Breiten ermitteln und in Array speichern
For lngSpalte = 1 To lngSpalteMax
For lngZeile = lngStartZeile To lngZeileLast '#####
If Len(.Cells(lngZeile, lngSpalte).Text) > arrBreite(lngSpalte) Then
arrBreite(lngSpalte) = Len(.Cells(lngZeile, lngSpalte).Text)
End If
Next
arrBreite(lngSpalte) = arrBreite(lngSpalte) + 2 '2 zusätlich für Leerzeichen
Next
'Zeilen der Tabelle einlesen
For lngZeile = lngStartZeile To lngZeileLast '#####
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
Const lngStartZeile = 10 'Zeile ab der Text-Datei erzeugt werden soll '#####
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 = lngStartZeile To lngZeileLast '#####
'nächste Tabelle suchen ("case id" oder "case Id" steht in Spalte A)
Do
lngZeile = lngZeile + 1
If lngZeile > lngZeileLast Then Exit Do
Loop Until InStr(1, LCase(.Cells(lngZeile, 1).Value), "case id") > 0 '#####
Sub Text_Export_Schritte_into_Clipboard()
Dim objData As DataObject
Dim varDatei, wks As Worksheet, intAnzahlZeichen As Integer
Dim lngZeileLast As Long, lngSpalteMax As Long
Dim lngZeile As Long, strText As String
Dim lngSpalte As Long, arrBreite() As Long
Dim strTextdaten As String
Const strSep = "||" 'Trennzeichen zwischen Daten-Spalten
Const lngStartZeile = 10 'Zeile ab der Text-Datei erzeugt werden soll
On Error GoTo Fehler
Set objData = New DataObject
Set wks = ActiveSheet
With wks
strTextdaten = ""
lngZeileLast = .UsedRange.Row + .UsedRange.Rows.Count - 1
'Letzte Spalte in Titelzeile ermitteln
lngSpalteMax = .Cells(lngStartZeile, .Columns.Count).End(xlToLeft).Column
ReDim arrBreite(1 To lngSpalteMax)
'Spalten Breiten ermitteln und in Array speichern
For lngSpalte = 1 To lngSpalteMax
For lngZeile = lngStartZeile To lngZeileLast
If Len(.Cells(lngZeile, lngSpalte).Text) > arrBreite(lngSpalte) Then
arrBreite(lngSpalte) = Len(.Cells(lngZeile, lngSpalte).Text)
End If
Next
arrBreite(lngSpalte) = arrBreite(lngSpalte) + 2 '2 zusätlich für Leerzeichen
Next
'Zeilen der Tabelle einlesen
For lngZeile = lngStartZeile To lngZeileLast
'Wert aus 1. Spalte einlesen
intAnzahlZeichen = arrBreite(1)
strText = LeerzeichenAuffuellen2(strText:=.Cells(lngZeile, 1).Text, _
intZeichen:=intAnzahlZeichen)
'Werte aus Spalten für Schritte einlesen
For lngSpalte = 2 To lngSpalteMax - 1
intAnzahlZeichen = arrBreite(lngSpalte)
strText = strText & strSep & LeerzeichenX(strText:=wks.Cells(lngZeile, _
lngSpalte).Text, intZeichen:=intAnzahlZeichen)
Next
'Hinweise einlesen
intAnzahlZeichen = arrBreite(lngSpalteMax)
strText = strText & strSep & LeerzeichenAuffuellen2(strText:=" " _
& .Cells(lngZeile, lngSpalteMax).Text, intZeichen:=intAnzahlZeichen)
'Zeile in Text-Datei schreiben
If strTextdaten = "" Then
strTextdaten = strText
Else
strTextdaten = strTextdaten & vbCr & strText
End If
'TrennZeile mit "-" nach Zeile der Tabelle einfügen
strText = String(arrBreite(1), "-")
For lngSpalte = 2 To lngSpalteMax
strText = strText & strSep & String(arrBreite(lngSpalte), "-")
Next
If strTextdaten = "" Then
strTextdaten = strText
Else
strTextdaten = strTextdaten & vbCr & strText
End If
Next
'Text-String in die Zwischenablage übertragen
objData.settext strTextdaten
objData.putinclipboard
MsgBox "Textdaten sind in Zwischenablage"
End With
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
Sub Text_Export_into_Clipboard()
Dim objData As DataObject
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, 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
Const lngStartZeile = 10 'Zeile ab der Text-Datei erzeugt werden soll
On Error GoTo Fehler
Set objData = New DataObject
Set wks = ActiveSheet
With wks
strTextdaten = ""
lngZeileLast = .UsedRange.Row + .UsedRange.Rows.Count - 1
For lngZeile = lngStartZeile To lngZeileLast
lngZeile1 = lngZeile
'nächste Tabelle suchen ("case id" oder "case Id" steht in Spalte A)
Do
lngZeile = lngZeile + 1
If lngZeile > lngZeileLast Then Exit Do
Loop Until InStr(1, LCase(.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
If strTextdaten = "" Then
strTextdaten = strText
Else
strTextdaten = strTextdaten & vbCr & strText
End If
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
strText = strText & strSep1 _
& LeerzeichenAuffuellen(strText:=wks.Cells(lngZ, _
lngSpalte).Text, intZeichen:=intAnzahlZeichen, bolLinks:=bolLinks)
Case Else
strText = strText & strSep _
& LeerzeichenAuffuellen(strText:=wks.Cells(lngZ, _
lngSpalte).Text, intZeichen:=intAnzahlZeichen, bolLinks:=bolLinks)
End Select
Next
'Zeile in Text-Datei schreiben
If strTextdaten = "" Then
strTextdaten = strText
Else
strTextdaten = strTextdaten & vbCr & strText
End If
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, "-")
If strTextdaten = "" Then
strTextdaten = strText
Else
strTextdaten = strTextdaten & vbCr & strText
End If
End If
Next
lngZeile = lngZeileE
Next
'Text-String in die Zwischenablage übertragen
objData.settext strTextdaten
objData.putinclipboard
MsgBox "Textdaten sind in Zwischenablage"
End With
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
C:\Temp\Testreport.txt
... nachdem nun der Report gespeichert wurde... soll Excel diese TXT Datei öffnen ... .. STRG+A ... STRG+C und dann wieder schließen .. und eine Message BOX kommt das alles erfolgt ist ...
Würde das denn realisierbar sein ?
DaNKE und Gruß
der Eddie
varDatei = Application.GetSaveAsFilename(InitialFileName:="TestExport.txt", _
Filefilter:="Text(*.txt), *.txt", _
Title:="Bitte Namen für Export-Datei wählen oder eingeben und speichern")
ändern in
varDatei = "C:\Temp\Testreport.txt"
und zusätzlich vor der Zeile
Fehler:
die Meldung einbauen
MsgBox "Daten wurden in Textdatei übertragen."
Gruß
Franz