The following code is a WIP. Everything works, except of the two commented out blocks. Any ideas? Thanks in advance!

1. Transferring Header Names
   After the first header was transferred from one sheet to another, the loop breaks for some reason

2. Getting Cell Names
   Always getting the error subscript out of range without even entering the loop once. The test tables have only two rows. The first one has a value, the other one is empty.

Option Explicit

Sub GetCellNames(CatRange As String, ArtRange As String)

Dim ws As Worksheet
Dim tbl As ListObject
Dim cellNames As Object
Dim headerArr As Variant
Dim cellArr As Variant
Dim tblName As String
Dim headerRow As String
Dim selectRow As String
Dim selectCol As String
Dim header As Range
Dim cell As Range

Set ws = Worksheets(Range(CatRange).Value)
tblName = Worksheets(1).Range(ArtRange).Value
Set tbl = ws.ListObjects(tblName)
Set cellNames = CreateObject("System.Collections.ArrayList")

selectCol = Chr(Asc(Left(ArtRange, 1)) + 1)
selectRow = Right(ArtRange, 1)
headerRow = Chr(Asc(selectRow) - 1)

'Getting Header Names
For Each header In tbl.HeaderRowRange.Cells
    If Not Right(header.Value, 1) = "2" Then
    
        '1. Transferring Header Names

‘ Worksheets(1).Range(selectCol + headerRow).Value = header.Value

        '2. Getting Cell Names

‘ For Each cell In tbl.ListColumns(header).DataBodyRange
‘ If Not IsEmpty(cell) Then cellNames.Add cell.Value
‘ Next cell

        ' Transform to Array
        cellArr = cellNames.ToArray
        ' Create Drop-Down List
        Call List.CreateDropDown(selectCol + selectRow, cellArr)
        
        selectCol = Chr(Asc(selectCol) + 1)
    End If
Next header

End Sub

1. No clue what to try

2. Tried already the following. Unfortunately, still the same error
   For Each cell In ws.Range(tblName).ListObject.ListColumns.Item(header).Range
   For Each cell In ws.Range(tblName + “[” + header + “]”)