Tabelle über VBA

Public Sub ConvertToListObject()
Const FOLDER_PATH As String = "Q:\Geschäftsführung\.....
Dim objWorkbook As Workbook
Dim objWorksheet As Worksheet
Dim objListObject As ListObject
Dim astrFolders() As String, strFileName As String
Dim ialngFolders As Long
Dim lglastRowA As Long
Dim lglastRowH As Long
On Error GoTo err_exit
With Application
.Cursor = xlWait
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
astrFolders = GetFolders(FOLDER_PATH)
For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
If astrFolders(ialngFolders) Like "*\2019\" Then
'Für andere Fälle
'         If astrFolders(ialngFolders) Like "*\2018\" Then
strFileName = Dir$(PathName:=astrFolders(ialngFolders) & "*.xlsx")
Do Until strFileName = vbNullString
Set objWorkbook = Workbooks.Open(Filename:=astrFolders(ialngFolders) &  _
strFileName)
For Each objWorksheet In objWorkbook.Worksheets
With objWorksheet
'Wo ist die letzte Zeile in Spalte A (Monatsende)
lglastRowA = .Cells(.Rows.Count, 1).End(xlUp).Row
Debug.Print lglastRowA
Set objListObject = .ListObjects.Add(SourceType:=xlSrcRange, _
Source:=.Range(.Cells(6, 1), .Cells(lglastRowA, 8).End(xlUp)), _
XlListObjectHasHeaders:=xlYes)
End With
With objListObject
.Name = "t_" & objWorksheet.Name
.TableStyle = "TableStyleMedium1"
End With
'                    With objWorksheet 'Den Wert in H? wieder löschen, siehe oben
'                        If .Cells(lglastRowA, 8).Value2 > 100 Then
'                             .Cells(lglastRowA, 8).ClearContents
'                        End If
'                    End With
Next
Call objWorkbook.Close(SaveChanges:=True)
Set objListObject = Nothing
Set objWorkbook = Nothing
strFileName = Dir$
Loop
End If
Next
sub_exit:
With Application
.Cursor = xlDefault
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
Exit Sub
err_exit:
Call MsgBox("Fehler: " & CStr(Err.Number) & vbLf & vbLf & _
Err.Description, vbCritical, "Programmfehler")
Resume sub_exit
End Sub

Private Function GetFolders(ByVal pvstrPath As String) As String()
Dim astrFolders() As String
Dim strFolder As String, strPath As String
Dim ialngIndex1 As Long, ialngIndex2 As Long
strPath = pvstrPath
Do
strFolder = Dir$(strPath & "*", vbDirectory)
Do Until strFolder = vbNullString
If strFolder  "." And strFolder  ".." Then
If GetAttr(strPath & strFolder) And vbDirectory Then
ReDim Preserve astrFolders(0 To ialngIndex1)
astrFolders(ialngIndex1) = strPath & strFolder & "\"
ialngIndex1 = ialngIndex1 + 1
End If
End If
strFolder = Dir$
Loop
If ialngIndex1 = ialngIndex2 Then Exit Do
strPath = astrFolders(ialngIndex2)
ialngIndex2 = ialngIndex2 + 1
Loop
GetFolders = astrFolders
End Function