Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1480to1484
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Abfrage ob Tabellenobjekt besteht

Abfrage ob Tabellenobjekt besteht
23.03.2016 13:28:13
Marcel
Mahlzeit :)
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

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Abfrage ob Tabellenobjekt besteht
23.03.2016 14:30:57
fcs
Hallo Marcel,
man kann "einfach" prüfen ob die Anzahl der Listobjekte = 0 ist.
Select-Anweisungen kann man meist vermeiden - sie fördern auch das Bildschirmflackern und erhöhen die Makro-Laufzeit.
Eine Fehlerbehandlung sollte so aufgebaut sein, dass man Fehlerhinweise bekommt und nicht einfach Fehler ignorieren.
Gruß
Franz
https://www.herber.de/bbs/user/104563.txt
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige