Excelのドロップダウンリストを、テーブルで自動で広げる方法

Option Explicit

' 入力規則に合わない値が入ったセルを、新しいシートに一覧にする（調べるだけで、何も変えない）
Sub ListInvalidEntries()
    Dim wb As Workbook, ws As Worksheet, out As Worksheet
    Dim rng As Range, c As Range, r As Long, src As String, f2 As String

    Set wb = ActiveWorkbook
    Set out = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
    out.Range("A1:D1").Value = Array("シート", "セル", "入っている値", "入力規則の元の値・条件")
    r = 2
    For Each ws In wb.Worksheets
        If Not ws Is out Then
            Set rng = Nothing
            On Error Resume Next                 ' 入力規則が1つもないシートではエラーになるため
            Set rng = Intersect(ws.UsedRange, ws.Cells.SpecialCells(xlCellTypeAllValidation))
            On Error GoTo 0
            If Not rng Is Nothing Then
                For Each c In rng
                    If c.Formula <> "" Then
                        If Not c.Validation.Value Then
                            src = ""
                            On Error Resume Next ' 元の値がない種類の入力規則もあるため
                            src = c.Validation.Formula1
                            f2 = ""
                            f2 = c.Validation.Formula2   ' 「1～100」のような範囲の上限
                            On Error GoTo 0
                            If f2 <> "" Then src = src & "～" & f2
                            out.Cells(r, 1).Value = ws.Name
                            out.Cells(r, 2).Value = c.Address(False, False)
                            out.Cells(r, 3).Value = "'" & c.Formula
                            out.Cells(r, 4).Value = "'" & src
                            r = r + 1
                        End If
                    End If
                Next c
            End If
        End If
    Next ws

    out.Columns("A:D").AutoFit
    MsgBox "入力規則に合わない値：" & (r - 2) & " か所" & vbCrLf & _
           "一覧は「" & out.Name & "」シートにあります。", vbInformation
End Sub