was muss ich ändern?
10.03.2022 10:04:06
erichm
Hallo Yal,
also der Code funktioniert sehr gut und das Ergebnis ist optimal.
Da ich den Code für mehrere Dateien benötige, speichere ich diesen in der PERSONL.xla ab. Wenn ich EXCEL öffne, erhalte ich immer eine Übersicht angezeigt, bei der ich diese Makros aufrufen kann. Das ist sehr komfortabel. Wenn ich jedoch diesen Code dort abspeichere und aufrufen will, dann klappt das nicht. Ich vermute, dass ich eine oder zwei bestimmte Stellen im Code ändern müsste - aber da reichen meine Kenntnisse leider nicht.
Mein Code beim öffnen von EXCEL und Anzeige der Liste der Makros (ich habe hier als Beispiel nur den Auszug für
Druckvorschau / Vorschau
IntTabellen = Dein Code mit ListObject_auflisten
angezeigt)
Option Explicit
Private Sub Workbook_Open()
Dim i%
i = Application.CommandBars(1).Controls.Count
With Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:= _
msoControlButton, Before:=i + 1, Temporary:=True)
.Caption = "&IV zurück"
.OnAction = "IV_zurück"
.Style = msoButtonIconAndCaption
End With
With Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:= _
msoControlPopup, Before:=i + 1, Temporary:=True)
.Caption = "&Personl.xls"
With .Controls.Add(Type:=msoControlPopup, Temporary:=True)
.Caption = "&Druckvorschau"
With .Controls.Add(Type:=msoControlButton, Temporary:=True)
.Caption = "&Bestand"
.OnAction = "Vorschau"
.Style = msoButtonIconAndCaption
End With
With .Controls.Add(Type:=msoControlButton, Temporary:=True)
.Caption = "&IntTabellen"
.OnAction = "IntTabellen"
.Style = msoButtonIconAndCaption
End With
End With
End Sub
Public Sub IntTabellen()
Dim ws As Worksheet
Dim LO As ListObject
Dim F As Range
Dim Headers As String
With WähleOderHerstelle("ListObjectListe", "Arbeitsblatt", "Tabelle", "Bereich", "Felder")
For Each ws In ThisWorkbook.Worksheets
For Each LO In ws.ListObjects
Headers = ""
For Each F In LO.HeaderRowRange.Cells
Headers = Headers & ", " & F.Value
Next
.Range("A9999").End(xlUp).Range("A2:D2") = Array(ws.Name, LO.Name, LO.DataBodyRange.Address(0, 0), Mid(Headers, 3))
Next
Next
End With
End Sub
Private Function WähleOderHerstelle(Blattname, ParamArray Headers()) As Worksheet
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(Blattname)
If ws Is Nothing Then
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = Blattname
Else
ws.Cells.ClearContents
End If
ws.Range("A1").Resize(1, UBound(Headers) + 1) = Headers
Set WähleOderHerstelle = ws
End Function
Der Änderungsbedarf liegt evtl. bei ThisWorkbook?
Nochmals besten Dank für eine Hilfe.
mfg