Hallo Bernd,
Ich habs ja versucht mit Tabellendarstellung erreicht mit FAQ
XXX, aber da kam immer ein Fehler Sub oder Prozedur nicht
gefunden oder so.
jepp. Lösch die Codezeile. Dann gibt es einen anderen Fehler, den auch beseitigen dann läuft der Code.
Oder nimm meinen nachstehenden Code, der funktioniert bei mir.
Den Code habe ich in meiner personl.xls in einem Modul stehen und benutze ihn schon lange indem ich ihn über ein Symbol in Excel starte.
Angeschaut habe ich mir ihn schon lange nicht mehr.
Insofern bin ich grad völlig ratlos wohin meine ganzen Einrückungen durch Leerzeichen verschwunden sind *sehr staun*
Und aus Zeitmangel hab ich es halt hochgeladen und im den Link
geschickt. Er soll es ja erst mal probieren.
Ja und, zeige den Link doch hier dann kann sich das Trampeltierchen *gg* oder schwere Elefanten wie ich auch daran versuchen .-)
Gruß
Reinhard
Option Explicit
Public intAnzS As Integer, lngAnzZ As Long, bytFehl As Byte, varNameZ, varNameS
Public varFormat, varBereich, varZeile, strLinie As String, varBreite, strLinieU As String
Public strSatz As String, strNamen As String, strFormeln As String, strMatrixformeln As String
Public strZF As String, varZahlenformat, wksAltesBlatt As Worksheet
'
Sub Excel2W\_W\_W()
' Programm zum formatierten Darstellen von Tabellenblattbereichen bei wer-weiss-was.
' Getestet auf XL97, entwickelt Nov. 2006, geändert Feb.2008 by Reinhard
' Wie man Vba-Code einfügt und ausführt siehe FAQ:4712[FAQ-Eintrag nicht gefunden]
' Benutzung: gewünschten Tabellenblattbereich per Maus oder Tastatur markieren und Makro
' ausführen lassen. Im Eingabefeld von w-w-w dann Strg+V drücken.
' Versionen höher als XL8.0 (=XL97) benötigen den Verweis auf "Microsoft Forms 2.0 Object Library"
' Der Verweis wird benötigt für "DataObject"
' Mit folgendem Code wird das Makro dem Tastenkürzel "Strg+w" zugewiesen, es empfiehlt sich
' den Code ins Modul "DiesArbeitsmappe" der Personl.xls zu kopieren, dann steht das Tastenkürzel
' in allen Dateien zur Verfügung
'
' Private Sub Workbook\_Open()
' Call VerweisSetzen
' Application.OnKey "^t", "w\_w\_w2Excel"
' Application.OnKey "^w", "Excel2W\_W\_W"
' End Sub
'
Dim objkurz As New DataObject, N
Set wksAltesBlatt = ActiveSheet
Call BereichEinlesen
If bytFehl = 255 Then Exit Sub
Call ZeilenErzeugen
Call TabelleinSatzEinfügen
objkurz.SetText strSatz
objkurz.PutInClipboard
Set objkurz = Nothing
'
' ab hier kann der nachfolgende Code (bis auf End Sub!) dieser Prozedur gelöscht werden,
' wenn man keine Kontrollausgabe in einem Hilfsblatt oder/und Notepad haben möchte
'
'\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\* Ausgabe in Hilfsblatt \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
'On Error Resume Next
'Application.DisplayAlerts = False
'ActiveWorkbook.Worksheets("Testxyz").Delete
'Application.DisplayAlerts = True
'Worksheets.Add after:=Worksheets(Worksheets.Count)
'ActiveSheet.Name = "Testxyz"
'With Columns(1).Font
' .Name = "Courier New"
' .Size = 10
'End With
'Range("A1").Select
'ActiveSheet.Paste
'ActiveSheet.Buttons.Add(244.5, 123.75, 111.75, 42.75).Select
'With Selection
' .OnAction = "PERSONL.XLS!BlattLoeschen"
' .Characters.Text = "Dieses Blatt löschen"
'End With
'Range("A1").Select
''\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\* Ausgabe in Notepad \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
'strSatz = Application.WorksheetFunction.Substitute(strSatz, Chr(13), "")
'strSatz = Application.WorksheetFunction.Substitute(strSatz, Chr(10), Chr(13) & Chr(10))
'objkurz.SetText strSatz
'objkurz.PutInClipboard
'Application.SendKeys "^v"
'N = Shell(Environ("systemroot") & "\notepad.exe", vbMaximizedFocus)
End Sub
'
Sub BereichEinlesen()
'Die Zellen (und ihre Formate) der Selection werden eingelesen
Dim lngZ As Long, intS As Integer
On Error GoTo Fehler
bytFehl = 1
If TypeName(Selection) "Range" Then GoTo Fehler
intAnzS = Selection.Columns.Count
lngAnzZ = Selection.Rows.Count
ReDim varBereich(lngAnzZ, intAnzS)
ReDim varFormat(lngAnzZ, intAnzS)
ReDim varZahlenformat(lngAnzZ, intAnzS)
ReDim varBreite(intAnzS)
ReDim varNameZ(lngAnzZ)
ReDim varNameS(intAnzS)
Call NamenZellen(Selection.Cells(1, 1).Address)
For lngZ = 1 To lngAnzZ
For intS = 1 To intAnzS
varZahlenformat(lngAnzZ, intAnzS) = Selection.Cells(lngZ, intS).NumberFormatLocal
varBereich(lngZ, intS) = Selection.Cells(lngZ, intS).Text
If Len(varBereich(lngZ, intS)) \> varBreite(intS) \_
Then varBreite(intS) = Len(varBereich(lngZ, intS))
varFormat(lngZ, intS) = XFormat(Selection.Cells(lngZ, intS))
Next intS
Next lngZ
For intS = 1 To intAnzS
If Len(varNameS(intS)) \> varBreite(intS) Then varBreite(intS) = Len(varNameS(intS))
Next intS
For lngZ = 1 To lngAnzZ
For intS = 1 To intAnzS
Select Case varFormat(lngZ, intS)
Case -4131
varBereich(lngZ, intS) = Left(varBereich(lngZ, intS) \_
& String(varBreite(intS), " "), varBreite(intS))
Case -4108
varBereich(lngZ, intS) = Left(String(Int((varBreite(intS) \_
- Len(varBereich(lngZ, intS))) / 2), " ") & varBereich(lngZ, intS) \_
& String(Int((varBreite(intS) - Len(varBereich(lngZ, intS))) / 2) \_
+ 1, " "), varBreite(intS))
Case -4152
varBereich(lngZ, intS) = Right(String(varBreite(intS), " ") \_
& varBereich(lngZ, intS), varBreite(intS))
Case Else
bytFehl = 2
GoTo Fehler
End Select
varBereich(lngZ, intS) = " " & varBereich(lngZ, intS) & " "
Next intS
Next lngZ
Exit Sub
Fehler:
Call Fehler(bytFehl)
End Sub
'
Sub tt()
Err.Raise vbObjectError + 100, , "Fehler mit der Selection"
End Sub
'
Sub Fehler(ByVal Nummer As Integer)
'Es wurden Fehler erkannt
Dim strMldg As String
Select Case Nummer
Case 1
strMldg = "Es wurde kein gültiger Zellenbereich selektiert"
Case 2
strMldg = "Problem mit Formatierung"
Case Else
strMldg = "Unbekannter Fehler"
End Select
MsgBox strMldg & Chr(13) & Chr(13) & "Makro wird beendet"
bytFehl = 255
End Sub
'
Sub NamenZellen(OberelinkeZelle As String)
'Ermittlung der Zeilen- und Spaltenbezeichnungen ausgehend von der oberen
'linken Zelle der Selektion.
'NamenZellen() wird von BereichEinlesen() aufgerufen
Dim lngZ As Long, intS As Integer, strAdr As String
For lngZ = 1 To lngAnzZ
varNameZ(lngZ) = Range(OberelinkeZelle).Offset(lngZ - 1, 0).Row
Next lngZ
For intS = 1 To intAnzS
strAdr = Range(OberelinkeZelle).Offset(0, intS - 1).Address
varNameS(intS) = Left(Mid(strAdr, 2), InStr(2, strAdr, "$") - 2)
Next intS
End Sub
'
Function XFormat(Zelle As Range)
'Ermittlung ob Zelleninhalt linksbündig, rechtsbündig oder zentriert ist.
'XFormat() wird von BereichEinlesen() aufgerufen
Select Case Zelle.HorizontalAlignment
Case -4131, -4108, -4152
XFormat = Zelle.HorizontalAlignment
Case Else
XFormat = 1
End Select
If XFormat = 1 Then
If IsDate(Zelle.Value) Or IsNumeric(Zelle.Value) Then XFormat = -4152
If IsError(Zelle.Value) Then XFormat = -4108
End If
If XFormat = 1 Then XFormat = -4131
End Function
'
Sub TabelleinSatzEinfügen()
'strSatz ist der Gesamtstring, der nachher in die Zwischenablage kopiert wird.
'in diesem Projekt wird er zusammengesetzt.
'strSatz besteht aus pre-Tag, Blattname, Tabelle, ggfs. Formeln, ggfs. Matrixformeln,
'ggfs. Namen, Zahlenformate, ggfs. Bed. Formatierungen, ggfs. erster Zirkelbezug
'/pre-Tag, Schlußfloskel
Dim lngZ As Long, intS As Integer
strSatz = Chr(60) & "pre" & Chr(62) & "Tabellenblatt: "
If ActiveWorkbook.Path "" Then strSatz = strSatz & ActiveWorkbook.Path & "\"
strSatz = strSatz & "[" & ActiveWorkbook.Name & "]!" & ActiveSheet.Name & vbLf
strSatz = strSatz & varZeile(0) & vbLf
For lngZ = 1 To lngAnzZ
strSatz = strSatz & strLinie & vbLf
strSatz = strSatz & varZeile(lngZ) & vbLf
Next lngZ
strSatz = strSatz & strLinieU
Call FormelMatrixNamenEinlesen
If strFormeln vbLf Then strSatz = strSatz & vbLf & "Benutzte Formeln:" & strFormeln
If strMatrixformeln vbLf Then
strSatz = strSatz & vbLf & "Benutzte Matrixformeln:" & strMatrixformeln
strSatz = strSatz & "(Matrixformeln nicht mit " & Chr(34) & "Enter" & Chr(34) \_
& " sondern mit " & Chr(34) & "Strg+Shift+Enter" & Chr(34) & " eingeben." & vbLf
strSatz = strSatz & "Die Spezialklammern nicht manuell eingeben, sie werden von Excel erzeugt.)"
End If
If strNamen vbLf Then strSatz = strSatz & vbLf & vbLf & "Festgelegte Namen:" & strNamen
Call ZahlenFormate
strSatz = strSatz & vbLf & strZF
'Call BedingteFormatierungEinlesen
'If strBF "Bedingte Formatierung(en):" & vbLf Then strSatz = strSatz & vbLf & strBF
'If Not ActiveSheet.CircularReference Is Nothing Then strSatz = strSatz & vbLf & vbLf \_
& "Zirkelbezug in Zelle: " & ActiveSheet.CircularReference.Address(0, 0) & vbLf
strSatz = strSatz & vbLf & Chr(60) & "/pre" & Chr(62) & \_
vbLf & "Tabellendarstellung erreicht mit dem Code in [FAQ:2363](/t/faq/9292363)" & vbLf
'strSatz = strSatz & "Dargestellte Tabelle kann man mit Code aus der gleichen FAQ in \_
' ein Tabellenblatt einfügen." & vbLf
strSatz = strSatz & "Gruß" & vbLf & "Reinhard" & vbLf 'Environ("Username")
End Sub
'
Sub ZeilenErzeugen()
'Die Zeilen der späteren Tabelle werden erstellt
Dim lngZ As Long, intS As Integer, Tr
Tr = Array(ChrW(9474), ChrW(9472), ChrW(9532), ChrW(9508), ChrW(9524), ChrW(9496))
ReDim varZeile(lngAnzZ)
varZeile(0) = String(Len(varNameZ(lngAnzZ)) + 1, " ") & Tr(0)
For lngZ = 1 To lngAnzZ
varZeile(lngZ) = Right(" " & varNameZ(lngZ), Len(varNameZ(lngAnzZ))) & " " & Tr(0)
For intS = 1 To intAnzS
varZeile(lngZ) = varZeile(lngZ) & varBereich(lngZ, intS) & Tr(0)
Next intS
Next lngZ
strLinie = String(Len(varNameZ(lngAnzZ)), Tr(1)) & Tr(1) & Tr(2)
strLinieU = String(Len(varNameZ(lngAnzZ)), Tr(1)) & Tr(1) & Tr(4)
For intS = 1 To intAnzS
strLinie = strLinie & String(varBreite(intS) + 2, Tr(1)) & Tr(2)
strLinieU = strLinieU & String(varBreite(intS) + 2, Tr(1)) & Tr(4)
varZeile(0) = varZeile(0) & Left(String(Int((varBreite(intS) + 2) / 2), " ") \_
& varNameS(intS) & String(varBreite(intS), " "), varBreite(intS) + 2) & Tr(0)
Next intS
strLinie = Left(strLinie, Len(strLinie) - 1) & Tr(3)
strLinieU = Left(strLinieU, Len(strLinieU) - 1) & Tr(5)
End Sub
'
Sub FormelMatrixNamenEinlesen()
'Formeln, Matrixformeln,Namen werdn eingelesen.
'Namen die sich auf einen relativen Zellbezug beziehen sind schlecht darzustellen
'denn jenachdem welche Zelle gerade aktiv ist ändert sich der Inhalt von ReferesTo
'Namen die sich auf einen relativen Zellbezug beziehen, werden, soweit vom Code erkannt,
'diesbezügluch in der Anzeige kommentiert.
Dim intS As Integer, lngZ As Long, intAnzN As Integer, LängeN As Integer, N As Integer
Dim Merker As Range, Ref1 As String, Ref2 As String, Ze As Range
Dim Merk As String, Vorh As Boolean
strFormeln = vbLf
strMatrixformeln = vbLf
strNamen = vbLf
Set Merker = Selection
With Selection
For intS = 1 To intAnzS
For lngZ = 1 To lngAnzZ
If .Cells(lngZ, intS).HasFormula And Not .Cells(lngZ, intS).HasArray Then \_
strFormeln = strFormeln & Left(.Cells(lngZ, intS).Address(0, 0) \_
& " ", Len(.Cells(lngAnzZ, intAnzS).Address(0, 0))) & ": " \_
& .Cells(lngZ, intS).FormulaLocal & vbLf
If .Cells(lngZ, intS).HasArray Then strMatrixformeln = strMatrixformeln \_
& Left(.Cells(lngZ, intS).Address(0, 0) & " ", \_
Len(.Cells(lngAnzZ, intAnzS).Address(0, 0))) & ": " & "{" & \_
.Cells(lngZ, intS).FormulaLocal & "}" & vbLf
Next lngZ
Next intS
intAnzN = ActiveWorkbook.Names.Count 'Anzahl der im Workbook benutzten Namen ermitteln
If intAnzN \>= 1 Then 'Wenn es Namen gibt
LängeN = Len(ActiveWorkbook.Names.Item(1).Name)
For N = 2 To intAnzN ' größte Namenslänge ermitteln
If LängeN Ref2 Then 'Relativer Name!
strNamen = strNamen & ActiveWorkbook.Names.Item(N).RefersToLocal & " \*rel. Name"
On Error Resume Next 'wg specialcells
If Not Intersect(Merker, ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas)) \_
Is Nothing Then
For Each Ze In Intersect(Merker, ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas))
If InStr(Ze.FormulaLocal, ActiveWorkbook.Names.Item(N).Name) \> 0 Then
Merk = Application.WorksheetFunction.Substitute(Ze.FormulaLocal, \_
ActiveWorkbook.Names.Item(N).Name, "")
If IsError(Evaluate(Merk)) = True Then
Ze.Select
strNamen = strNamen & ", so gültig in " & Ze.Address(0, 0)
Exit For
End If
End If
Next Ze
End If
Else
strNamen = strNamen & ActiveWorkbook.Names.Item(N).RefersToLocal
End If
If ActiveWorkbook.Names.Item(N).Visible = False Then strNamen = strNamen \_
& ", \*versteckter Name"
Vorh = False
On Error Resume Next
If Not Intersect(Merker, ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas)) Is Nothing Then
For Each Ze In Intersect(Merker, ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas))
If InStr(Ze.FormulaLocal, ActiveWorkbook.Names.Item(N).Name) \> 0 Then
Merk = Application.WorksheetFunction.Substitute(Ze.FormulaLocal, ActiveWorkbook.Names.Item(N).Name, "")
If IsError(Evaluate(Merk)) = True Then
Vorh = True
Exit For
End If
End If
Next Ze
End If
On Error GoTo 0
If Vorh = False Then strNamen = strNamen & ", unbenutzt in Selektion."
strNamen = strNamen & vbLf
Next N
End If
End With
Merker.Select
End Sub
'
Sub ZahlenFormate()
'Wenn in der Selection verschiedene Zahlenformate vorkommen werden diese in "Col"
'gespeichert. "Col" wird in einer Schleife abgearbeitet und in einer Unterschleife
'wird ermittelt welche zellen das jeweilige zahlenformat in "Col" haben.
Dim Col As New Collection, C As Long, lngZ As Long, intS As Integer
Dim strZFkurz As String, strMldg As String, intPos As Integer
strZF = "Zahlenformate der Zellen im gewählten Bereich:" & vbLf
If Not Selection.NumberFormatLocal = Empty Then
strZF = Selection.Address(0, 0) & vbLf & IIf(Selection.Cells.Count 1, "haben", "hat")
strZF = strZF & " das Zahlenformat: "
strZF = strZF & IIf(Selection.NumberFormatLocal = "@", "Text", Selection.NumberFormatLocal) & vbLf
Else
On Error Resume Next 'wg. Col
For intS = 1 To Selection.Columns.Count
With Selection.Columns(intS)
If Not .NumberFormatLocal = Empty Then
Col.Add Item:=.NumberFormatLocal, key:=.NumberFormatLocal
varZahlenformat(0, intS) = .NumberFormatLocal
C = C + 1
End If
End With
Next intS
If C intAnzS Then
For intS = 1 To intAnzS
If varZahlenformat(0, intS) = "" Then
For lngZ = 1 To lngAnzZ
Col.Add Item:=Selection.Cells(lngZ, intS).NumberFormatLocal, key:=Selection.Cells(lngZ, intS).NumberFormatLocal
varZahlenformat(lngZ, intS) = Selection.Cells(lngZ, intS).NumberFormatLocal
Next lngZ
End If
Next intS
End If
On Error GoTo 0
For C = 1 To Col.Count
For intS = 1 To intAnzS
If varZahlenformat(0, intS) "" Then
If Col.Item(C) = varZahlenformat(0, intS) Then
strZF = strZF & Selection.Columns(intS).Address(0, 0) & ","
End If
Else
strZFkurz = ""
For lngZ = 1 To lngAnzZ
If Col.Item(C) = varZahlenformat(lngZ, intS) Then
strZFkurz = strZFkurz & Selection.Cells(lngZ, intS).Address(0, 0) & ","
End If
Next lngZ
strZF = strZF & BereicheZ(strZFkurz)
End If
Next intS
strMldg = IIf(InStr(strZF, ",") = Len(strZF) And InStr(strZF, ":") = 0, "hat", "haben")
strZF = Left(strZF, Len(strZF) - 1) & vbLf & strMldg & " das Zahlenformat: " & IIf(Col.Item(C) = "@", "Text", Col.Item(C)) & vbLf
Next C
strZF = BereicheS(strZF)
End If
End Sub
'
Function BereicheZ(ByVal F As String) As String
'Zusammengehörende Zellen einer Spalte werden zusammengefasst zu einem Bereich
'um die Anzeigenbreite bei Zahlenformaten zu verkleinern
'Bereiche() wird von Zahlenformate() aufgerufen wenn in einer Spalte verschiedene
'Zahlenformate vorhanden sind.
Dim M As Long, N As Long, lngPos As Long, g() As Variant, Anz As Long
Dim lngOff As Long
While InStr(lngPos + 1, F, ",") \> 0
Anz = Anz + 1
ReDim Preserve g(Anz)
g(Anz) = Mid(F, lngPos + 1, InStr(lngPos + 1, F, ",") - lngPos - 1)
lngPos = InStr(lngPos + 1, F, ",")
Wend
If Anz = 1 Then
BereicheZ = g(1) & ","
Exit Function
End If
Anz = Anz + 1
ReDim Preserve g(Anz)
g(Anz) = g(1) 'Dummmy
For N = 1 To UBound(g) - 1
lngOff = 1
While Range(g(N)).Offset(lngOff, 0).Address(0, 0) = Range(g(N + lngOff)).Address(0, 0)
lngOff = lngOff + 1
Wend
BereicheZ = BereicheZ & g(N)
If lngOff \> 1 Then BereicheZ = BereicheZ & ":" & Range(g(N)).Offset(lngOff - 1, 0).Address(0, 0)
BereicheZ = BereicheZ & ","
N = N + lngOff - 1
Next N
End Function
'
Function BereicheS(ByVal F As String) As String
'Zellen in Spalten zusammenfassen wenn zusammengehörig,
Dim Anz, Pos, Zellen, PosZ, g() As Variant, AnzZ, N, lngOff, PosK
While InStr(Pos + 1, F, vbLf) \> 0
Zellen = Mid(F, Pos + 1, InStr(Pos + 1, F, vbLf) - Pos)
If InStr(Zellen, "Zahlen") \> 0 Then
BereicheS = BereicheS & Zellen
Else
PosZ = 0
Zellen = Zellen & ",IU65530," 'Dummy anfügen
AnzZ = 0
While InStr(PosZ + 1, Zellen, ",") \> 0
AnzZ = AnzZ + 1
ReDim Preserve g(AnzZ)
g(AnzZ) = Mid(Zellen, PosZ + 1, InStr(PosZ + 1, Zellen, ",") - PosZ - 1)
PosZ = InStr(PosZ + 1, Zellen, ",")
Wend
For N = 1 To UBound(g) - 1
g(N) = Application.WorksheetFunction.Substitute(g(N), vbLf, "")
'MsgBox InStr(g(N), vbLf)
If InStr(g(N), ":") = 0 Then
lngOff = 1
While Range(g(N)).Offset(0, lngOff).Address(0, 0) = Range(g(N + lngOff)).Address(0, 0)
lngOff = lngOff + 1
Wend
BereicheS = BereicheS & g(N)
If lngOff \> 1 Then BereicheS = BereicheS & ":" & Range(g(N)).Offset(0, lngOff - 1).Address(0, 0)
BereicheS = BereicheS & ","
N = N + lngOff - 1
Else
BereicheS = BereicheS & Application.WorksheetFunction.Substitute(g(N), vbLf, "") & ","
End If
Next N
If Right(BereicheS, 1) = "," Then BereicheS = Left(BereicheS, Len(BereicheS) - 1)
BereicheS = BereicheS & vbLf
End If
Pos = InStr(Pos + 1, F, vbLf)
Anz = Anz + 1
Wend
Pos = 0
While InStr(Pos + 1, BereicheS, vbLf) \> 0
Zellen = Mid(BereicheS, Pos + 1, InStr(Pos + 1, BereicheS, vbLf) - Pos)
If InStr(Zellen, "Zahlen") = 0 Then
PosK = Pos
While Len(Zellen) \> 70
PosK = InStr(PosK + 70, BereicheS, ",")
Mid(BereicheS, PosK, 1) = vbLf
Zellen = Mid(Zellen, 70)
Wend
End If
Pos = InStr(Pos + 1, BereicheS, vbLf)
Wend
BereicheS = Left(BereicheS, Len(BereicheS) - 1)
End Function
