Live-Forum - Die aktuellen Beiträge
Datum
Titel
18.04.2024 21:09:11
4 Spalten aus smarter Tabelle in andere smarte Tab. kopieren
18.04.2024 20:45:35
Worksheet_Activate für alle Sheets
18.04.2024 19:30:20
VBA - Tabelle mit Mannschaftsergebnissen sortieren
18.04.2024 18:04:29
Formel fehler Wert#
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1312to1316
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1312to1316
1312to1316
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Inhaltsverzeichnis per Makro - Ergänzung

Inhaltsverzeichnis per Makro - Ergänzung
11.05.2013 11:59:03
tuska
Hallo,
ich habe mit Hilfe des Forums ein Makro "Blattliste" aufgezeichnet, welches aus sämtlichen Blättern einer Arb.Mappe autom. ein Inhaltsverzeichnis (Blatt "INHALT") erzeugt und die Blätter per Hyperlink aufrufbar sind.
https://www.herber.de/bbs/user/85282.xls
Das Blatt "INHALT" wird autom. im Hochformat erzeugt.
Kann mich bitte jemand unterstützen und mir mitteilen, welchen Makrocode ich auf Modul 10 einfügen muß, damit ich autom. nach Erstellung ein "Querformat" für den Ausdruck erzielen kann. (xls, xlt)
Eventuell kann mir jemand auch hier Hilfestellung geben:
In dieser Arb.Mappe habe ich ein paar nützliche Makros gesammelt (aus dem Forum u. Zeitschrift). Die zwei Makros "Check" u. "Prüfruotine" habe ich mir mit dem weiterduplizieren von Arb.Mappen schon vor Jahren 'eingehandelt'- sie lassen sich von mir nicht entfernen. Gibt es irgendeine Möglichkeit die Einträge loszuwerden?
Danke im voraus für die Unterstützung.
Gruß
Karl

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Inhaltsverzeichnis per Makro - Ergänzung
11.05.2013 15:51:03
tuska
Hallo,
ich habe jetzt mal den Code mit dem Macrorecorder aufgezeichnet (Seite einrichten / Querformat)
und in dem Makro "Blattliste" einfach nach "End With" in der vorletzten Zeile eingefügt.
Die Erstellung des Inhaltsverzeichnisses dauert dann ein bißchen länger, aber das Blatt besitzt dann das Querformat. Vielleicht gäbe es da noch einen kürzeren Code, der das Bildschirmflimmern ausschaltet.
Aber grundsätzlich ist dieses Problem für mich gelöst.
Die zwei Makroeinträge, die sich nicht löschen lassen, umgehe ich künftig, indem ich gewisse Dateien nicht weiterdupliziere sondern komplett neue Arbeitsmappen anlege.
Gruß
Karl

Anzeige
AW: Inhaltsverzeichnis per Makro - Ergänzung
11.05.2013 16:44:11
fcs
Hallo Karl,
um das Bildschirmflackern zu minimieren muss du die Re-Aktivierung der Bildschirmaktualisierung an das Ende der Prozedur verschieben.
Die beiden Geister-Makros hängen irgendwie mit den definierten Namen in der Datei zusammen.
Ich hab in der Datei mal alle Namen mit Bezugfehler gelöscht. Dann Datei speichern, schliessen und wieder öffnen. Danach waren die beiden Geister-Makros nicht mehr in der Makro-Auswahlliste.
Gruß
Franz
Sub Blattliste()
Dim objWs As Worksheet, objIndex As Worksheet
Dim lngI As Long, n As Integer
Dim strName As String, strNumber
strName = "INHALT"
On Error Resume Next
Set objIndex = Sheets(strName)
If Not objIndex Is Nothing Then
Do
Set objIndex = Nothing
n = n + 1
strNumber = Format(n, " 00")
Set objIndex = Sheets(strName & strNumber)
Loop While Not objIndex Is Nothing
End If
On Error GoTo ErrExit
Application.ScreenUpdating = False
Set objIndex = Worksheets.Add(before:=Sheets(1))
With objIndex
.Name = strName & strNumber
.Columns.ColumnWidth = 7
.Cells(3, 2) = "Nr."
.Cells(3, 3) = "Inhaltsverzeichnis (Strg + i)"
.Cells(3, 4) = "Titel"
.Cells(3, 5) = "Anmerkung"
.Columns(2).HorizontalAlignment = xlCenter
.Columns(3).ColumnWidth = 33
.Columns(4).ColumnWidth = 33
.Columns(5).ColumnWidth = 33
With .Range("B3:E3")
.BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
.PageSetup.Orientation = xlLandscape                            'Zeile neu
End With
ActiveWindow.DisplayGridlines = False
For Each objWs In ActiveWorkbook.Worksheets
If Not objWs Is objIndex Then
lngI = lngI + 1
With objIndex
.Cells(lngI + 3, 2) = lngI
.Hyperlinks.Add Anchor:=.Cells(lngI + 3, 3), _
Address:="", _
SubAddress:="'" & Replace(objWs.Name, "'", "''") & "'!A2", _
TextToDisplay:=objWs.Name
End With
End If
Next
With objIndex.Range("B4:E" & lngI + 3)
.Font.Underline = False
.BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
ActiveWindow.ScrollRow = 1
objIndex.Range("C3").Activate
ErrExit:
Set objIndex = Nothing
Set objWs = Nothing
Cells.Select
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
Range("C3").Select
End With
Application.ScreenUpdating = True             'Zeile verschoben
End Sub

Anzeige
AW: Inhaltsverzeichnis per Makro - Ergänzung
11.05.2013 18:05:35
tuska
Hallo Franz,
herzlichen Dank, daß Du meinen Beitrag so genau gelesen hast und nochmals DANKE für Deine Lösungen!
Für mich ist das Makro jetzt perfekt und die "Geister"-Makros bin ich jetzt (nach Jahren!) auch losgeworden.
Der gesamte Code zum Makro "Blattliste" sieht jetzt so aus: 
Sub Blattliste()
Dim objWs As Worksheet, objIndex As Worksheet
Dim lngI As Long, n As Integer
Dim strName As String, strNumber
LG
Karl
strName = "INHALT"
On Error Resume Next
Set objIndex = Sheets(strName)
If Not objIndex Is Nothing Then
Do
Set objIndex = Nothing
n = n + 1
strNumber = Format(n, " 00")
Set objIndex = Sheets(strName & strNumber)
Loop While Not objIndex Is Nothing
End If
On Error GoTo ErrExit
Application.ScreenUpdating = False
Set objIndex = Worksheets.Add(Before:=Sheets(1))
With objIndex
.Name = strName & strNumber
.Columns.ColumnWidth = 7
.Cells(3, 2) = "Nr."
.Cells(3, 3) = "Inhaltsverzeichnis (Strg + i)"
.Cells(3, 4) = "Titel"
.Cells(3, 5) = "Anmerkung"
.Columns(2).HorizontalAlignment = xlCenter
.Columns(3).ColumnWidth = 33
.Columns(4).ColumnWidth = 33
.Columns(5).ColumnWidth = 33
With .Range("B3:E3")
.BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
.PageSetup.Orientation = xlLandscape                            'Zeile neu
End With
ActiveWindow.DisplayGridlines = False
For Each objWs In ActiveWorkbook.Worksheets
If Not objWs Is objIndex Then
lngI = lngI + 1
With objIndex
.Cells(lngI + 3, 2) = lngI
.Hyperlinks.Add Anchor:=.Cells(lngI + 3, 3), _
Address:="", _
SubAddress:="'" & Replace(objWs.Name, "'", "''") & "'!A2", _
TextToDisplay:=objWs.Name
End With
End If
Next
With objIndex.Range("B4:E" & lngI + 3)
.Font.Underline = False
.BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
ActiveWindow.ScrollRow = 1
objIndex.Range("C3").Activate
ErrExit:
Set objIndex = Nothing
Set objWs = Nothing
Cells.Select
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
Range("C3").Select
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.787401575)
.RightMargin = Application.InchesToPoints(0.787401575)
.TopMargin = Application.InchesToPoints(0.984251969)
.BottomMargin = Application.InchesToPoints(0.984251969)
.HeaderMargin = Application.InchesToPoints(0.4921259845)
.FooterMargin = Application.InchesToPoints(0.4921259845)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
End With
Application.ScreenUpdating = True
End With
End Sub

Gruß
Karl
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige