Hallo Interessierte,
Kurztest verlief erfolgreich, aber k.A. welche Bugs Features im Code noch enthalten sind. Wird sich im Laufe der Zeit rausstellen.
Bevor der Code in die FAQ aufgenommen werden kann wäre es gut er würde ausgetestet, einfach durch Benutzung.
Die erste Sub stellt ausgewählte Tabellenbereiche in w-w-w dar. Die zweite liest sie wieder aus und stellt sie in der aktuellen Tabelle dar.
Nachfolgend die Codes.
Gruß
Reinhard
Option Explicit
Sub Bereich2W\_W\_W()
' Programm zum formatierten Darstellen von Tabellenblattbereichen bei wer-weiss-was.
' November 2006 by Reinhard
'
' Getestet in XL97. Möglicherweise muss man in höheren Excelversionen wegen dem DataObject
' im Editor bei Extras--Verweise den Verweis auf "Microsoft Forms 2.0 Object Library" setzen.
'
' Code am besten in Modul1 der personl.xls bzw. personal.xls.
'
' 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.
'
Dim AnzS As Integer, AnzZ As Long, Z As Long, S As Integer
Dim Satz As String, Kurz As DataObject, Vorne As String, Hinten As String
Dim Trenn As String, Trenn2 As String, Linie2 As String, Linie3 As String, Trenn3 As String
Dim Formeln As String, AnzF, Namen, AnzN, LängeN, N
Application.Calculation = xlCalculationManual
Trenn = " " & ChrW(9474) & " " '9472 9532
Trenn2 = ChrW(9472) & ChrW(9532) & ChrW(9472)
Trenn3 = ChrW(9472) & ChrW(9524) & ChrW(9472)
With Selection
AnzS = .Columns.Count 'Anzahl Spalten im markierten Tabellenbereich
AnzZ = .Rows.Count 'Anzahl der Zeilen im markierten Tabellenbereich
ReDim Breite(AnzS) 'jede Spalte hat eine ggfs unterschiedliche Breite
ReDim Zeilensatz(AnzZ) 'die Zellen einer Zeile ergeben dann jeweils einen Zeilensatz
Zeilensatz(0) = String(Len(.Cells(AnzZ, 1).Row), " ") ' Zeilensatz(0) bekommt vorne soviel Leerzeichen wie die Breite der größten Zeilennummer
Linie2 = String(Len(.Cells(AnzZ, 1).Row), ChrW(9472))
Linie3 = String(Len(.Cells(AnzZ, 1).Row), ChrW(9472))
For Z = 1 To AnzZ ' jeder Zeilensatz erhält vorne die Zeilennummer
Zeilensatz(Z) = Right(String(Len(Zeilensatz(0)), " ") & .Cells(Z, 1).Row, Len(Zeilensatz(0)))
Next Z
For S = 1 To AnzS 'Schleife um pro Spalte die jeweilig höchste Breite zu ermitteln
Breite(S) = 0
For Z = 1 To AnzZ
If Len(.Cells(Z, S).Text) \> Breite(S) Then Breite(S) = Len(.Cells(Z, S).Text)
Next Z
If Breite(S) 0 Then Vorne = Vorne & " "
Zeilensatz(0) = Zeilensatz(0) & Trenn & Vorne & Bezeichnung(.Cells(Z, S).Column) & Hinten
Linie2 = Linie2 & Trenn2 & String(Breite(S), ChrW(9472))
Linie3 = Linie3 & Trenn3 & String(Breite(S), ChrW(9472))
Next S
Zeilensatz(0) = Zeilensatz(0) & Trenn
Linie2 = Linie2 & ChrW(9472) & ChrW(9508) '9524
Linie3 = Linie3 & ChrW(9472) & ChrW(9496) '9524
For S = 1 To AnzS ' die Zeilensätze erhalten Spalte für Spalte die Zellinhalte
For Z = 1 To AnzZ
Select Case TypeName(.Cells(Z, S).Value)
Case "Error"
Vorne = String(Int((Breite(S) - Len(.Cells(Z, S).Text)) / 2), " ")
Hinten = Vorne
If (Breite(S) - Len(.Cells(Z, S).Text)) Mod 2 0 Then Vorne = Vorne & " "
Zeilensatz(Z) = Zeilensatz(Z) & Trenn & Vorne & .Cells(Z, S).Text & Hinten
Case Else
Vorne = String(Breite(S) - Len(Trim(.Cells(Z, S).Text)), " ")
Zeilensatz(Z) = Zeilensatz(Z) & Trenn & Vorne & .Cells(Z, S).Text
End Select
Next Z
Next S
For Z = 1 To AnzZ
Zeilensatz(Z) = Zeilensatz(Z) & Trenn
For S = 1 To AnzS
If .Cells(Z, S).HasFormula Then Formeln = Formeln & Left(.Cells(Z, S).Address(0, 0) & " ", Len(.Cells(AnzZ, AnzS).Address(0, 0))) & ": " & .Cells(Z, S).FormulaLocal & vbLf
Next S
Next Z
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 = 1 To AnzN
If LängeN "" Then Satz = Satz & ActiveWorkbook.Path & "\"
Satz = Satz & "[" & ActiveWorkbook.Name & "]!" & ActiveSheet.Name & vbLf & vbLf
' die Zeilensätze werden in Satz gesammelt
Satz = Satz & Zeilensatz(0) & vbLf & Linie2 & vbLf
For Z = 1 To AnzZ
Satz = Satz & Zeilensatz(Z) & vbLf
Next Z
Satz = Satz & Linie3 & vbLf
If Formeln "" Then Satz = Satz & vbLf & "Benutzte Formeln:" & vbLf & Formeln
If Namen "" Then Satz = Satz & vbLf & "Benutzte Namen:" & vbLf & Namen
Satz = Satz & vbLf & "Tabellendarstellung erreicht mit dem Code in FAQ4711" & vbLf
' Satz erhält hinten den pre-Tag
Satz = Satz & Chr(60) & "/pre" & Chr(62)
End With
' Satz wird in die Zwischenablage geschrieben
Set Kurz = New DataObject
Kurz.SetText Satz
Kurz.PutInClipboard
Set Kurz = Nothing
Application.Calculation = xlCalculationAutomatic
End Sub
Function Bezeichnung(Spalte As Integer) As String
Dim N As Byte, Adr As String
Adr = Cells(1, Spalte).Address
' die Spaltenbezeichnng wird aus der Adresse der obersten Zelle in der Spalte extrahiert
For N = 2 To InStr(2, Adr, "$") - 1
Bezeichnung = Bezeichnung & Mid(Adr, N, 1)
Next N
End Function
Sub W\_W\_W2Bereich()
' Programm zum Zellenrichtigen Übertragen von Tabellenblattbereichen die mittels dem Makro
' "Bereich2W\_W\_W" bei w-w-w gepostet wurden.
' November 2006 by Reinhard
'
' Getestet in XL97. Möglicherweise muss man in höheren Excelversionen wegen dem DataObject
' im Editor bei Extras--Verweise den Verweis auf "Microsoft Forms 2.0 Object Library" setzen.
'
' Code am besten in Modul1 der personl.xls bzw. personal.xls.
'
' Benutzung: in w-w-w den geposteten Tabellenblattbereich inklusive möglicher Formeln und Namen
' per Maus oder Tastatur markieren und Strg+C drücken.
' In Excel dann dieses Makro ausführen lassen.
'
Dim AnzS As Integer, AnzZ As Long, Z As Long, S As Integer
Dim Satz As String, Kurz As DataObject, Vorne As String, Hinten As String, Spalten()
Dim Trenn As String, Trenn2 As String, Linie2 As String, Linie3 As String, Trenn3 As String
Dim Zeilensatz(), SatzN, SatzF, Such, Namen(), Formeln(), AnzF, AnzN, Mldg, N, Zeilen()
Dim Zellen(), von, lang, Bezug, Formel
Set Kurz = New DataObject
Kurz.GetFromClipboard
Satz = Kurz.GetText(1)
Such = "Benutzte Namen:"
If InStr(Satz, Such) Then ' Benutzte Namen extrahieren
SatzN = Mid(Satz, InStr(Satz, Such) + Len(Such) + 2)
Satz = Left(Satz, InStr(Satz, Such) - 1)
While (InStr(SatzN, vbLf))
AnzN = AnzN + 1
ReDim Preserve Namen(AnzN)
Namen(AnzN) = Left(SatzN, InStr(SatzN, vbLf) - 1)
SatzN = Mid(SatzN, InStr(SatzN, vbLf) + 1)
Wend
End If
Such = "Benutzte Formeln:"
If InStr(Satz, Such) Then ' Benutzte Formeln extrahieren
SatzF = Mid(Satz, InStr(Satz, Such) + Len(Such) + 2)
Satz = Left(Satz, InStr(Satz, Such) - 1)
While (InStr(SatzF, vbLf))
AnzF = AnzF + 1
ReDim Preserve Formeln(AnzF)
Formeln(AnzF) = Left(SatzF, InStr(SatzF, vbLf) - 1)
SatzF = Mid(SatzF, InStr(SatzF, vbLf) + 1)
Wend
End If
While (InStr(Satz, vbLf))
AnzZ = AnzZ + 1
ReDim Preserve Zeilensatz(AnzZ)
Zeilensatz(AnzZ) = Left(Satz, InStr(Satz, vbLf) - 1)
Satz = Mid(Satz, InStr(Satz, vbLf) + 1)
Wend
For Z = 1 To AnzZ
If InStr(Zeilensatz(Z), ChrW(9474)) Then Exit For
Next Z
If Z \> AnzZ Then
Mldg = "kein senkrechter Strich gefunden"
GoTo Fehler
End If
AnzS = 0
For N = 1 To Len(Zeilensatz(Z)) 'ermittlung der Spaltenbezeichnungen Spalten()
If Mid(Zeilensatz(Z), N, 1) \>= "A" And Mid(Zeilensatz(Z), N, 1) " " Then
N = N + 1
Spalten(AnzS) = Spalten(AnzS) & Mid(Zeilensatz(Z), N, 1)
End If
End If
Next N
Z = Z + 2
' Einlesen der Zellwerte
While (AscW(Left(Zeilensatz(Z), 1)) = "0" And Mid(Zeilensatz(Z), N, 1) 0 And InStr(InStr(N, Zeilensatz(Z), ChrW(9474)) + 1, Zeilensatz(Z), ChrW(9474)) \> 0)
S = S + 1
von = InStr(N, Zeilensatz(Z), ChrW(9474)) + 1
lang = InStr(InStr(N, Zeilensatz(Z), ChrW(9474)) + 1, Zeilensatz(Z), ChrW(9474)) - von
ActiveSheet.Range(Spalten(S) & CInt(Zeilen(AnzZ))) = Trim(Mid(Zeilensatz(Z), von, lang))
N = InStr(N, Zeilensatz(Z), ChrW(9474)) + 1
MsgBox ActiveSheet.Range(Spalten(S) & CInt(Zeilen(AnzZ))).Address
Wend
Z = Z + 1
Wend
For N = 1 To AnzN ' Einlesen der Namen
Bezug = Mid(Namen(N), InStr(Namen(N), ":") + 3)
Bezug = Left(Bezug, Len(Bezug) - 1)
ActiveWorkbook.Names.Add Name:=Trim(Left(Namen(N), InStr(Namen(N), ":") - 1)), RefersTo:=Bezug
Next N
For N = 1 To AnzF ' Einlesen der Formeln
If InStr(Formeln(N), "=") Then
Formel = Mid(Formeln(N), InStr(Formeln(N), "="))
Formel = Left(Formel, Len(Formel) - 1)
Range(Trim(Left(Formeln(N), InStr(Formeln(N), ":") - 1))).FormulaLocal = Formel
End If
Next N
Set Kurz = Nothing
Exit Sub
Fehler:
MsgBox Mldg
End Sub