Hallo Interessierte,
auf http://www.hostarea.de/server-02/Februar-9742903811.xls
ist eine neue Variante um hier Tabellen formatiert darzustellen. Dazugekommen ist die horizontale Ausrichtung der Werte in den Zellen, das Auslesen der bedingten Formatierung usw.
Bei der bedingten Formatierung war Ypsilon(Micha) sehr beteiligt.
Rückmeldungen was nicht geht wäre nett, mit Angabe der XLversion.
Übrigens, weiß jmd. wie ich kann ich aus einer „Unterprozedur“ eine „Oberprozedur“ beenden?
Dies bräuchte ich um in der Sub Fehler alles beenden zu können.
Im Anhang der relevante Code aus Modul1 und Modul5, die anderen Module in der Datei spielen keine Rolle.
Danke schonmal ^ Gruß
Reinhard
Modul1:
Option Explicit
Private AnzS As Integer, AnzZ As Long, Fehl As Byte
Private NameZ, NameS, Format, Bereich, Zeile, Linie, Breite, LinieU
Private Satz As String, Namen, Formeln, Matrixformeln
Private ZF, Zahlenformat
'
Sub Excel2W\_W\_W()
Dim Kurz As New DataObject, Merker As Range
Set Merker = Selection
Call Satzkopf
Call BereichEinlesen
Call ZeilenErzeugen
Call TabelleinSatzEinfügen
Call FormelMatrixNamenEinlesen
Set Kurz = New DataObject
Kurz.SetText Satz
Kurz.PutInClipboard
Set Kurz = Nothing
Merker.Select
'in Blatt2 Courier 16.67 Pitch als Schriftart einstellen oder andere nichtproportionale Schrift
Worksheets("Tabelle2").Activate
ActiveSheet.UsedRange.ClearContents
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
End Sub
'
Sub BereichEinlesen()
Dim Z As Long, S As Integer
On Error GoTo Fehler
Fehl = 1
If TypeName(Selection) "Range" Then GoTo Fehler
AnzS = Selection.Columns.Count
AnzZ = Selection.Rows.Count
ReDim Bereich(AnzZ, AnzS)
ReDim Format(AnzZ, AnzS)
ReDim Zahlenformat(AnzZ, AnzS)
ReDim Breite(AnzS)
ReDim NameZ(AnzZ)
ReDim NameS(AnzS)
Call NamenZellen(Selection.Cells(1, 1).Address)
For Z = 1 To AnzZ
For S = 1 To AnzS
Zahlenformat(AnzZ, AnzS) = Selection.Cells(Z, S).NumberFormatLocal
Bereich(Z, S) = Selection.Cells(Z, S).Text
If Len(Bereich(Z, S)) \> Breite(S) Then Breite(S) = Len(Bereich(Z, S))
Format(Z, S) = XFormat(Selection.Cells(Z, S))
Next S
Next Z
For S = 1 To AnzS
If Len(NameS(S)) \> Breite(S) Then Breite(S) = Len(NameS(S))
Next S
For Z = 1 To AnzZ
For S = 1 To AnzS
Select Case Format(Z, S)
Case -4131
Bereich(Z, S) = Left(Bereich(Z, S) & String(Breite(S), " "), Breite(S))
Case -4108
Bereich(Z, S) = Left(String(Int((Breite(S) - Len(Bereich(Z, S))) / 2), " ") & Bereich(Z, S) & String(Int((Breite(S) - Len(Bereich(Z, S))) / 2) + 1, " "), Breite(S))
Case -4152
Bereich(Z, S) = Right(String(Breite(S), " ") & Bereich(Z, S), Breite(S))
Case Else
Fehl = 2
GoTo Fehler
End Select
Bereich(Z, S) = " " & Bereich(Z, S) & " "
Next S
Next Z
Exit Sub
Fehler:
Call Fehler(Fehl)
End Sub
'
Sub tt()
Err.Raise vbObjectError + 100, , "Fehler mit der Selection"
End Sub
'
Sub Fehler(ByVal Nummer As Integer)
Dim Mldg As String
Select Case Nummer
Case 1
Mldg = "Es wurde kein gültiger Zellenbereich selektiert"
Case 2
Mldg = "Problem mit Formatierung"
Case Else
Mldg = "Unbekannter Fehler"
End Select
MsgBox Mldg & Chr(13) & Chr(13) & "Makro wird beendet"
End Sub
'
Sub NamenZellen(OberelinkeZelle As String)
Dim Z As Long, S As Integer, Zelle As String
For Z = 1 To AnzZ
NameZ(Z) = Range(OberelinkeZelle).Offset(Z - 1, 0).Row
Next Z
For S = 1 To AnzS
Zelle = Range(OberelinkeZelle).Offset(0, S - 1).Address
NameS(S) = Left(Mid(Zelle, 2), InStr(2, Zelle, "$") - 2)
Next S
End Sub
'
Function XFormat(Zelle As Range)
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 Satzkopf()
Satz = Chr(60) & "pre" & Chr(62) & vbLf & "Tabellenblatt: "
If ActiveWorkbook.Path "" Then Satz = Satz & ActiveWorkbook.Path & "\"
Satz = Satz & "[" & ActiveWorkbook.Name & "]!" & ActiveSheet.Name & vbLf
End Sub
'
Sub TabelleinSatzEinfügen()
Dim Z As Long, S As Integer
Satz = Satz & Zeile(0) & vbLf
For Z = 1 To AnzZ
Satz = Satz & Linie & vbLf
Satz = Satz & Zeile(Z) & vbLf
Next Z
Satz = Satz & LinieU & vbLf
Satz = Satz & Chr(60) & "/pre" & Chr(62) & vbLf
If Formeln "" Then Satz = Satz & vbLf & "Benutzte Formeln:" & vbLf & Formeln
If Matrixformeln "" Then
Satz = Satz & vbLf & "Benutzte Matrixformeln:" & vbLf
Satz = Satz & "(Matrixformeln nicht mit " & Chr(34) & "Enter" & Chr(34) & " sondern mit " & Chr(34) & "Strg+Shift+Enter" & Chr(34) & " eingeben." & vbLf
Satz = Satz & "Die Spezialklammern nicht manuell eingeben, sie werden von Excel erzeugt.)" & vbLf & Matrixformeln
End If
If Namen "" Then Satz = Satz & vbLf & "Benutzte Namen:" & vbLf & Namen & vbLf
Call ZahlenFormate
Satz = Satz & ZF
Call BedingteFormatierungEinlesen
If BF "Bedingte Formatierung(en):" & vbLf Then Satz = Satz & BF & vbLf
Satz = Satz & "Tabellendarstellung erreicht mit dem Code in [FAQ:2363](/t/faq/9292363)" & vbLf
'Satz = Satz & "Dargestellte Tabelle kann man mit Code aus der gleichen FAQ in ein Tabellenblatt einfügen." & vbLf
Satz = Satz & vbLf & "Gruß" & vbLf & "Reinhard" 'Environ("Username")
End Sub
'
Sub ZeilenErzeugen()
Dim Z As Long, S As Integer, Tr
Tr = Array(ChrW(9474), ChrW(9472), ChrW(9532), ChrW(9508), ChrW(9524), ChrW(9496))
ReDim Zeile(AnzZ)
Zeile(0) = String(Len(NameZ(AnzZ)) + 1, " ") & Tr(0)
For Z = 1 To AnzZ
Zeile(Z) = Right(" " & NameZ(Z), Len(NameZ(AnzZ))) & " " & Tr(0)
For S = 1 To AnzS
Zeile(Z) = Zeile(Z) & Bereich(Z, S) & Tr(0)
Next S
Next Z
Linie = String(Len(NameZ(AnzZ)), Tr(1)) & Tr(1) & Tr(2)
LinieU = String(Len(NameZ(AnzZ)), Tr(1)) & Tr(1) & Tr(4)
For S = 1 To AnzS
Linie = Linie & String(Breite(S) + 2, Tr(1)) & Tr(2)
LinieU = LinieU & String(Breite(S) + 2, Tr(1)) & Tr(4)
Zeile(0) = Zeile(0) & Left(String(Int((Breite(S) + 2) / 2), " ") & NameS(S) & String(Breite(S), " "), Breite(S) + 2) & Tr(0)
Next S
Linie = Left(Linie, Len(Linie) - 1) & Tr(3)
LinieU = Left(LinieU, Len(LinieU) - 1) & Tr(5)
End Sub
'
Sub FormelMatrixNamenEinlesen()
Dim S As Integer, Z As Long, AnzN As Integer, LängeN As Integer, N As Integer
Formeln = ""
Matrixformeln = ""
Namen = ""
With Selection
For S = 1 To AnzS
For Z = 1 To AnzZ
If .Cells(Z, S).HasFormula And Not .Cells(Z, S).HasArray Then Formeln = Formeln & Left(.Cells(Z, S).Address(0, 0) & " ", Len(.Cells(AnzZ, AnzS).Address(0, 0))) & ": " & .Cells(Z, S).FormulaLocal & vbLf
If .Cells(Z, S).HasArray Then Matrixformeln = Matrixformeln & Left(.Cells(Z, S).Address(0, 0) & " ", Len(.Cells(AnzZ, AnzS).Address(0, 0))) & ": " & "{" & .Cells(Z, S).FormulaArray & "}" & vbLf
Next Z
Next S
AnzN = ActiveWorkbook.NameS.Count 'Anzahl der im Workbook benutzten Namen ermitteln
If AnzN \>= 1 Then 'Wenn es Namen gibt
LängeN = Len(ActiveWorkbook.NameS.Item(1).Name)
For N = 2 To AnzN ' größte Namenslänge ermitteln
If LängeN AnzS Then
For S = 1 To AnzS
If Zahlenformat(0, S) = "" Then
For Z = 1 To AnzZ
Col.Add Item:=Selection.Cells(Z, S).NumberFormatLocal, key:=Selection.Cells(Z, S).NumberFormatLocal
Zahlenformat(Z, S) = Selection.Cells(Z, S).NumberFormatLocal
Next Z
End If
Next S
End If
For C = 1 To Col.Count
For S = 1 To AnzS
If Zahlenformat(0, S) "" Then
If Col.Item(C) = Zahlenformat(0, S) Then
ZF = ZF & Selection.Columns(S).Address(0, 0) & ","
End If
Else
ZFkurz = ""
For Z = 1 To AnzZ
If Col.Item(C) = Zahlenformat(Z, S) Then
ZFkurz = ZFkurz & Selection.Cells(Z, S).Address(0, 0) & ","
End If
Next Z
Mldg = IIf(InStr(ZFkurz, ",") = Len(ZFkurz) And InStr(ZFkurz, ":") = 0, "hat", "haben")
ZF = ZF & Bereiche(ZFkurz)
End If
Next S
ZF = Left(ZF, Len(ZF) - 1) & vbLf & Mldg & " das Zahlenformat: " & Col.Item(C) & vbLf & vbLf
Next C
End If
End Sub
'
Function Bereiche(ByVal F As String) As String
Dim M As Long, N As Long, Pos As Long, G() As Variant, Anz As Long
Dim Von, Off
While InStr(Pos + 1, F, ",") \> 0
Anz = Anz + 1
ReDim Preserve G(Anz)
G(Anz) = Mid(F, Pos + 1, InStr(Pos + 1, F, ",") - Pos - 1)
Pos = InStr(Pos + 1, F, ",")
Wend
If Anz = 1 Then
Bereiche = 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
Von = N
Off = 1
While Range(G(N)).Offset(Off, 0).Address(0, 0) = Range(G(N + Off)).Address(0, 0)
Off = Off + 1
Wend
Bereiche = Bereiche & G(N)
If Off \> 1 Then Bereiche = Bereiche & ":" & Range(G(N)).Offset(Off - 1, 0).Address(0, 0)
Bereiche = Bereiche & ","
N = N + Off - 1
Next N
End Function
Modul5
Option Explicit
Public BF As String, Zelle As Range, i As Byte
'
Sub BedingteFormatierungEinlesen()
' Code in diesem Modul weitestgehend entwickelt von Ypsilon (Micha)
BF = "Bedingte Formatierung(en):" & vbLf
If Selection.FormatConditions.Count = 0 Then GoTo Ende
For Each Zelle In Selection
Zelle.Select
For i = 1 To Zelle.FormatConditions.Count
BF = BF & Zelle.Address(0, 0) & ": "
With Zelle.FormatConditions.Item(i)
If .Type = 1 Then
BF = BF & "Zellwert ist "
Select Case .Operator
Case 1
BF = BF & "zwischen "
BF = BF & .Formula1 & " und "
BF = BF & .Formula2 & vbLf
erfüllte\_bedingung
Case 2
BF = BF & "nicht zwischen "
BF = BF & .Formula1 & " und "
BF = BF & .Formula2 & vbLf
erfüllte\_bedingung
Case 3
BF = BF & "gleich "
BF = BF & .Formula1 & " "
erfüllte\_bedingung
Case 4
BF = BF & "ungleich "
BF = BF & .Formula1 & " "
erfüllte\_bedingung
Case 5
BF = BF & "größer "
BF = BF & .Formula1 & " "
erfüllte\_bedingung
Case 6
BF = BF & "kleiner "
BF = BF & .Formula1 & " "
erfüllte\_bedingung
Case 7
BF = BF & "größer gleich "
BF = BF & .Formula1 & " "
erfüllte\_bedingung
Case 8
BF = BF & "kleiner gleich "
BF = BF & .Formula1 & " "
erfüllte\_bedingung
End Select
ElseIf .Type = 2 Then
BF = BF & "Formel ist "
BF = BF & .Formula1 & vbLf
erfüllte\_bedingung
Else
MsgBox "Unbekannter Typ: " & .Type & vbLf & "Admin anrufen!"
Exit Sub
End If
End With
Next
Next Zelle
Ende:
End Sub
'
Sub BedingteFormatierungEinlesen2()
If Selection.FormatConditions.Count = 0 Then Exit Sub
BF = "Bedingte Formatierung:" & vbLf
For Each Zelle In Selection
For i = 1 To Zelle.FormatConditions.Count
BF = BF & Zelle.Address(0, 0) & ": "
With Zelle.FormatConditions.Item(i)
Select Case .Type
Case 1
BF = BF & "Zellwert ist "
Nummer = .Operator
Case 2
BF = BF & "Formel ist "
Nummer = 9
Case Else
MsgBox "papst anbeten"
Exit Sub
End Select
End With
Call FormatFormel(Nummer, .Formula1, .Formula2)
Call erfüllte\_bedingung
Next i
Next Zelle
End Sub
'
Sub erfüllte\_bedingung()
With Zelle.FormatConditions.Item(i).Interior
'Farbe
If Not .ColorIndex = Empty Then BF = BF & "Bei erfüllter Bedingung wird die Zelle " & Zelle.Address(0, 0) & " mit dem Colorindex " & .ColorIndex & " eingefärbt" & vbLf
'Muster
If Not .Pattern = Empty Then BF = BF & "Bei erfüllter Bedingung wird die Zelle " & Zelle.Address(0, 0) & " mit dem Muster " & .Pattern & " versehen" & vbLf
'Musterfarbe
If Not .PatternColorIndex = Empty Then BF = BF & "Bei erfüllter Bedingung wird das Zellenmuster " & Zelle.Address(0, 0) & " mit der Farbe " & .PatternColorIndex & " versehen" & vbLf
End With
With Zelle.FormatConditions.Item(i).Font
'Schriftfarbe -4105=Automatische farbe
If Not .ColorIndex = Empty Then BF = BF & "Bei erfüllter Bedingung wird die Zellenschrift in " & Zelle.Address(0, 0) & " mit der Schriftfarbe " & .ColorIndex & " eingefärbt" & vbLf
'Schriftart
If Not .Name = Empty Then BF = BF & "Bei erfüllter Bedingung wird die Zelle " & Zelle.Address(0, 0) & " mit dem Font " & .Name & " versehen" & vbLf
'Schriftstärke
If Not .FontStyle = Empty Then BF = BF & "Bei erfüllter Bedingung wird die Zelle " & Zelle.Address(0, 0) & " mit der Schriftstärke " & .FontStyle & " versehen" & vbLf
'Schriftgrösse
If Not .Size Then BF = BF & "Bei erfüllter Bedingung wird die Zelle " & Zelle.Address(0, 0) & " mit der Schriftgrösse " & .Size & " versehen" & vbLf
End With
With Selection.FormatConditions(i).Borders(xlLeft)
If Not .LineStyle = Empty Then BF = BF & "Bei erfüllter Bedingung erhält die Zelle " & Zelle.Address(0, 0) & " links eine " & Linienart(.LineStyle) & "-Linie in der Breite " & Liniendicke(.Weight) & " mit Farbe " & .ColorIndex & vbLf
End With
With Selection.FormatConditions(i).Borders(xlRight)
If Not .LineStyle = Empty Then BF = BF & "Bei erfüllter Bedingung erhält die Zelle " & Zelle.Address(0, 0) & " rechts eine " & Linienart(.LineStyle) & "-Linie in der Breite " & Liniendicke(.Weight) & " mit Farbe " & .ColorIndex & vbLf
End With
With Selection.FormatConditions(i).Borders(xlTop)
If Not .LineStyle = Empty Then BF = BF & "Bei erfüllter Bedingung erhält die Zelle " & Zelle.Address(0, 0) & " oben eine " & Linienart(.LineStyle) & "-Linie in der Breite " & Liniendicke(.Weight) & " mit Farbe " & .ColorIndex & vbLf
End With
With Selection.FormatConditions(i).Borders(xlBottom)
If Not .LineStyle = Empty Then BF = BF & "Bei erfüllter Bedingung erhält die Zelle " & Zelle.Address(0, 0) & " unten eine " & Linienart(.LineStyle) & "-Linie in der Breite " & Liniendicke(.Weight) & " mit Farbe " & .ColorIndex & vbLf
End With
'noch offen :frowning: gibt es die Möglichkeiten alle ? \*grummel\*
' With Selection.Font
' .Strikethrough = False
' .Superscript = False
' .Subscript = False
' .OutlineFont = False
' .Shadow = False
' .Underline = xlUnderlineStyleNone
' End With
End Sub
'
Sub FormatFormel(ByVal Nummer As Byte, ByVal Bed1, Optional ByVal Bed2)
On Error GoTo Fehler
Dim Wahl, Zelle, N
Wahl = Array("Dummy", "zwischen", "nicht zwischen", "gleich", "ungleich", "größer", "kleiner", "größer gleich", "kleiner gleich", "Formel ist")
Select Case Nummer
Case 1, 2
BF = BF & Wahl(Nummer) & Bed1 & "und" & Bed2 & vbLf
Case 3 To 9
BF = BF & Wahl(Nummer) & Bed1 & vbLf
Case Else
MsgBox "papst anbeten"
End Select
Exit Sub
Fehler:
MsgBox "bla"
End Sub
'
Function Liniendicke(ByVal Nummer) As String
'xlHairline, xlThin, xlMedium oder xlThick. Long Schreib-Lese-Zugriff.
Select Case Nummer
Case 1
Liniendicke = "xlHairline"
Case 2
Liniendicke = "xlThin"
Case -4138
Liniendicke = "xlMedium"
Case 4
Liniendicke = "xlxlThick"
Case Else
MsgBox "Fehler mit Liniendicke"
End Select
End Function
'
Function Linienart(ByVal Nummer) As String
Select Case Nummer
Case 1
Linienart = "xlContinuous"
Case -4115
Linienart = "xlDash"
Case 4
Linienart = "xlDashDot"
Case 5
Linienart = "xlDashDotDot"
Case -4118
Linienart = "xlDot"
Case -4119
Linienart = "xlDouble"
Case 13
Linienart = "xlSlantDashDot"
Case -4142
Linienart = "xlLineStyleNone"
Case Else
MsgBox "Fehler mit Linienart"
End Select
End Function
