Excel Tabelle in Textform konvertieren
27. Oktober 2006
Der markierte Bereich wird spaltenweise auf die Textlänge untersucht und damit die Breite der Spalten (Anzahl der Buchstaben) festgelegt. Dabei wird die Text-Eigenschaft des Range-Objektes verwendet, so dass der angezeigte Text erscheint.
Das Makro ist besonders geeignet, um Tabellenausschnitte in der Microsoft Excel Newsgroup einzufügen.
Das Ergebnis sieht dann so aus:
VBA:
-
+--------+-----------+----------+
-
|Dieses |Makro |erstellt |
-
+--------+-----------+----------+
-
|perfekt |formatierte|ASCII |
-
+--------+-----------+----------+
-
|Tabellen|per |Knopfdruck|
-
+--------+-----------+----------+
Makro als Add-In kostenlos herunterladen (inkl. Menüleiste): Profi-ExcelAdd-In
VBA:
-
Sub exportAscii()
-
'konvertiert den markierten Tabellenbereich in
-
'eine Tabelle im Textformat
-
'10-2006
-
'©E.Bimczok
-
'http://www.profi-excel.de/
-
Const mypath As String = "c:\tempAsciiTable.txt"
-
-
Dim myRng As Range
-
Dim myCol As Range
-
Dim myCell As Range
-
Dim myLen As Long
-
Dim maxLen As Long
-
Dim numRows As Long
-
Dim numCols As Long
-
Dim AsciiOut() As String
-
Dim AsciiCount As Long
-
Dim fF As Long
-
Dim noOfSpaces As Long
-
Dim spaceStr As String
-
-
Set myRng = Selection
-
numRows = myRng.Rows.Count
-
numCols = myRng.Columns.Count
-
ReDim AsciiOut(1 To numRows * 2 + 1)
-
-
For Each myCol In myRng.Columns
-
maxLen = 0
-
For Each myCell In myCol.Rows
-
myLen = Len(myCell.Text)
-
maxLen = maxAB(maxLen, myLen)
-
Next myCell
-
-
AsciiCount = 1
-
For Each myCell In myCol.Rows
-
AsciiOut(AsciiCount) = AsciiOut(AsciiCount) & _
-
"+" & String(maxLen, "-")
-
AsciiCount = AsciiCount + 1
-
AsciiOut(AsciiCount) = AsciiOut(AsciiCount) & _
-
"|" & myCell.Text
-
noOfSpaces = maxLen - Len(myCell.Text)
-
spaceStr = ""
-
If noOfSpaces> 0 Then spaceStr = String(noOfSpaces, " ")
-
AsciiOut(AsciiCount) = AsciiOut(AsciiCount) & spaceStr
-
AsciiCount = AsciiCount + 1
-
Next myCell
-
AsciiOut(numRows * 2 + 1) = AsciiOut(1)
-
Next myCol
-
-
For k = 1 To numRows * 2 + 1
-
AsciiOut(k) = AsciiOut(k) & Left(AsciiOut(k), 1)
-
Next k
-
-
fF = FreeFile
-
Open mypath For Output As #fF
-
For k = 1 To UBound(AsciiOut)
-
Print #fF, AsciiOut(k)
-
Next k
-
Close #fF
-
-
Shell "notepad.exe " & mypath, vbNormalFocus
-
End Sub
-
-
Function maxAB(A As Long, B As Long) As Long
-
If A>= B Then
-
maxAB = A
-
Else
-
maxAB = B
-
End If
-
End Function