Habe ein Makro das voll funktioniert.
Es ermittelt die Tabelle und legt eine Tabelle an.
Problem, Dateien die bereits eine Tabelle enthalten wirft er mir als Fehler aus und bricht ab...Wie kann ich hier eine Plausibilität einbauen, sodass er bei bereits bestehenden Tabellen zur nächsten Datei weiter geht?
Vielen Dank.
Sub MWMultiDateiUpdateTEST()
Dim oSourceBook As Object
Dim strPfad As String
Dim strDatei As String
Dim lngLetzteZeile As Long
Dim lngLetzteSpalte As Long
Dim BrowseDir As Variant
Dim AppShell As Object
Dim ws As Worksheet
Dim lstList As ListObject
Application.ScreenUpdating = False 'Das "Flackern" ausstellen
MsgBox "Bitte wählen Sie den Ordner aus, in dem sich die Excel-Dateien befinden."
'Schritt 1: Schleife über alle Excel Dateien in einem Verzeichnis
Set AppShell = CreateObject("Shell.Application")
Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17)
On Error Resume Next
strPfad = BrowseDir.items().Item().Path
If strPfad = "" Then Exit Sub
On Error GoTo 0
strDatei = Dir(strPfad & "\*.xl*") 'Alle Excel Dateien
Do While strDatei ""
'Schritt 2: öffnen der Datei und Datenübertragung
Set oSourceBook = Workbooks.Open(strPfad & "\" & strDatei, False, False) 'nur
lesend öffnen
'Set oSourceBook = Workbooks.Open(strPfad & strDatei)
'Änderungen durchführen
'Ermittle erste Zeile und letzte Spalte
lngLetzteZeile = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
lngLetzteSpalte = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Column
'Bereich markieren
Sheets(1).UsedRange.Select
'Schleife für Plausibilität einbauen - funktioniert NICHT
Set ws = ActiveSheet
For Each lstList In ws.ListObjects
If lstList.Name = "Tabelle1" Then
Exit For
End If
If lstList "Tabelle1" Then
MsgBox "Es gibt keine Liste"
Set lstList = Sheets(1).ListObjects.Add(xlSrcRange, Sheets
(1).UsedRange, , xlYes). _
Name = _
"Tabelle1"
Exit For
End If
Next
'Ab hier geht der Code wieder.
'Kommando um Tabelle aufzulösen
'Set Sheets(1).UsedRange.Select = Sheets(1).ListObjects("Tabelle1").Unlist
'Tabelle erstellen
'Set Sheets(1).UsedRange.Select = Sheets(1).ListObjects.Add(xlSrcRange, Sheets(1).UsedRange, _
_
, xlYes).Name = _
"Tabelle1"
'Unternehmensorange auf Tabelle anwenden
'Sheets(1).ListObjects("Tabelle1").TableStyle = "TableStyleMedium3"
'Spalten markieren und an Inhalt anpassen
Columns("A:A").Select
Range(Selection, Selection.End(xlToRight)).Select
Columns.EntireColumn.AutoFit
'Schritt 3: Datei speichern und wieder zu machen und nächste Schleifenrunde
Application.DisplayAlerts = False
oSourceBook.Close True 'speichern
Application.DisplayAlerts = True
'Nächste Datei
strDatei = Dir()
Loop
Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder
einschalten
'Variablen aufräumen
Set oSourceBook = Nothing
MsgBox "Alle Dateien wurden erfolgreich bearbeitet."
End Sub