AW: Hallo Nepomuk, die Struktur ist..
06.03.2019 11:50:14
Nepumuk
Hallo Georg,
teste mal:
Option Explicit
Public Sub ConvertToListObject()
Const FOLDER_PATH As String = "G:\Eigene Dateien\" 'Anpassen
Dim objWorkbook As Workbook
Dim objWorksheet As Worksheet
Dim objListObject As ListObject
Dim astrFolders() As String, strFileName As String
Dim ialngFolders 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
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
Set objListObject = .ListObjects.Add(SourceType:=xlSrcRange, _
Source:=.Range(.Cells(6, 1), .Cells(.Rows.Count, 8).End(xlUp)), _
XlListObjectHasHeaders:=xlYes)
End With
With objListObject
.Name = "t_" & objWorksheet.Name
.TableStyle = "TableStyleMedium1"
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
Gruß
Nepumuk