Unterordner durchsuchen Excel VBA
01.03.2017 20:51:45
niki
Hi, ich habe mir ein Makro gebastelt, mit dem ich Daten aus mehreren Word Tabellen auslesen kann. Das Makro durchsucht alle Word Dokumente in einem Ordner, es sollte aber möglichst auch alle Unterordner in diesem Ordner durchsuchen. Zudem würde ich gerne Dokumente mit der Endung .docx UND .docm durchsuchen. Ist das möglich?
Hier mein Code:
Sub WordtabelleEinlesen()
Dim sPfad As String
Dim appWord As Object
Dim fd As FileDialog
Dim arrDaten
Dim zeichnung
Dim material
Dim bezeichnung
Dim cam
Dim vorrichtung1
Dim vorrichtung2
Dim vorrichtung3
Dim vorrichtung4
Dim strDatei As String
Dim loLetzte As Long
sPfad = "O:\ODE\Data\Produktion ODP\AVOR\allgemein\Laserprogramme - Überarbeitung\Test Makro _
Word Einrichtblätter Schüler\Original\" '<== Pfad anpassen
Application.ScreenUpdating = False
Set appWord = CreateObject("Word.Application")
appWord.Visible = True
strDatei = Dir(sPfad & "*.docx") '<== Dateiendung anpassen
Do While strDatei <> ""
appWord.Documents.Open sPfad & strDatei, , True 'fragt nich immer nach, ob dokument _
schreibgeschützt geöffnet werden soll
If appWord.activeDocument.Tables.Count > 1 Then ' <== Abfrage ob mindestens 2 Tabellen _
enthalten sind
tabelle = appWord.activeDocument.Tables(1).Cell(1, 3)
zeichnung = appWord.activeDocument.Tables(1).Cell(2, 3)
material = appWord.activeDocument.Tables(1).Cell(3, 3)
bezeichnung = appWord.activeDocument.Tables(1).Cell(4, 3)
cam = appWord.activeDocument.Tables(1).Cell(5, 3)
vorrichtung1 = appWord.activeDocument.Tables(1).Cell(10, 2)
vorrichtung2 = appWord.activeDocument.Tables(1).Cell(11, 2)
vorrichtung3 = appWord.activeDocument.Tables(1).Cell(12, 2)
vorrichtung4 = appWord.activeDocument.Tables(1).Cell(13, 2)
arrDaten = Split(Application.Substitute(appWord.activeDocument.Tables(1), Chr(7), ""), Chr(13) & _
Chr(13))
With ThisWorkbook.Worksheets("Tabelle1").Columns(1)
loLetzte = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows. _
Count) + 1
strInhalt = Mid(arrDaten(1), InStr(arrDaten(1), Chr(13)) + 1)
'strInhalt = Mid(strInhalt, 1, InStr(strInhalt, Chr(13)) - 1)
.Cells(loLetzte, 1) = tabelle
.Cells(loLetzte, 2) = zeichnung
.Cells(loLetzte, 3) = material
.Cells(loLetzte, 4) = bezeichnung
.Cells(loLetzte, 5) = cam
.Cells(loLetzte, 6) = vorrichtung1
.Cells(loLetzte, 7) = vorrichtung2
.Cells(loLetzte, 8) = vorrichtung3
.Cells(loLetzte, 9) = vorrichtung4
Columns("A:I").AutoFit
End With
End If
appWord.activeDocument.Close savechanges:=False
strDatei = Dir
Loop
appWord.Quit
Set appWord = Nothing
Set fd = Nothing
End Sub