Als Antwort auf diesen Beitrag
Hi,
hab den Code mal erweitert auf alle Blätter (bzw. auf alle Blätter mit Monatsnamen).
Wenn weitere Monate dazukommen, dann muss Du das Array entsprechend erweitern.
Um es sauber zu machen:
Füge den Code in ein ALLGEMEINES Modul ein (Einfügen - Modul).
Dann starte ihn mit F5.
Option Explicit
Sub til()
Dim c As Range, x As Long, Ws As Worksheet, Ws2 As Worksheet
On Error Resume Next
Set Ws = Worksheets("Auflistung")
If Ws Is Nothing Then
Set Ws = Worksheets.Add
Ws.Name = "Auflistung"
End If
x = 2
Ws.Cells.ClearContents
Ws.Cells(1, 1) = "Zelle"
Ws.Cells(1, 2) = "Bezug"
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
For Each Ws2 In Worksheets(Array("Januar", "Februar", "März", "April", "Mai", "Juni", "Juli", "August"))
For Each c In Ws2.Cells.SpecialCells(xlCellTypeAllValidation)
If c.Validation.InCellDropdown Then
Ws.Cells(x, 1) = c.Address(0, 0, , True)
Ws.Cells(x, 2) = "'" & c.Validation.Formula1
x = x + 1
End If
Next c
Next Ws2
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Ws.Columns("A:B").AutoFit
End Sub
VG, Boris