faule Sache
08.09.2016 13:51:41
Michael
Hi Margarete,
anbei die faule Lösung, bei der Du die 4 von den Kollegen gewünschten Verzeichnisse fix in eine Konstante eingibst, die dann wiederum mit split in ein Array verwandelt wird, das dann in der For-Schleife abgearbeitet wird.
Option Explicit
Option Private Module
Const strSheetQ As String = "Tabelle1" ' DIE Tabelle wird ausgelesen"
Const strSheetZ As String = "Protokoll" ' Die Tabelle in DIESER Datei
Const strCellQ As String = "B1" ' Diese Zelle wird ausgelesenPublic Sub Main()
' die ändern sich doch sowieso nicht, oder?
Const UO = "C:\A\A?C:\A\B?C:\A\C?C:\A\D" ' alle 4 Pfade
Dim arrUO, iUO&
Dim strThisworkbookName As String
Dim objWorkbook As Workbook
Dim strFolder As String
Dim strFilename As String
Dim lngLastRow As Long
Dim lngCalc As Long
On Error GoTo Fin
' strFolder = ThisWorkbook.Path & "\"
' strFolder = Environ("USERPROFILE") & "\Desktop\Protokolle\" ' MB angepasst
strThisworkbookName = ThisWorkbook.Name
With Application
lngCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
.ShowWindowsInTaskbar = False
.DisplayAlerts = False
End With
arrUO = Split(UO, "?")
With ThisWorkbook.Worksheets(strSheetZ)
.Rows("2:" & .Rows.Count).Clear
For iUO = LBound(arrUO) To UBound(arrUO) ' *****
If arrUO(iUO) "" Then ' falls ein ? falsch gesetzt wurde
strFilename = Dir$(arrUO(iUO) & "*.xls*") ' *******
Do Until strFilename = vbNullString
If strFilename strThisworkbookName Then
Set objWorkbook = Workbooks.Open(Filename:= _
strFolder & strFilename, UpdateLinks:=3)
Call objWorkbook.Save
lngLastRow = IIf(Len(.Cells(.Rows.Count, 2)), _
.Rows.Count, .Cells(.Rows.Count, 2).End(xlUp).Row) + 1
.Cells(lngLastRow, 1).Value = strFilename
.Cells(lngLastRow, 1).Hyperlinks.Add Anchor:=.Cells(lngLastRow, 1), _
Address:=strFolder & strFilename
.Cells(lngLastRow, 2).Value = objWorkbook.Worksheets(strSheetQ).Range("B1")
Call objWorkbook.Close(SaveChanges:=False)
Set objWorkbook = Nothing
End If
strFilename = Dir$()
Loop
End If ' *****
Next ' *****
End With
Fin:
With Application
.EnableEvents = True
.ScreenUpdating = True
.ShowWindowsInTaskbar = True
.Calculation = lngCalc
.DisplayAlerts = True
.CutCopyMode = True
End With
If Err.Number 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
So geht das mit minimalen Änderungen. Der Punkt ist, daß "Dir" nicht rekursiv funktioniert, d.h. man kann es nicht ohne Weiteres bei verschachtelten Unterverzeichnissen einsetzen.
WAS man tun könnte, um die Variabilität zu erhalten, ist, das Array nicht aus der Konstanten zu füllen, sondern mit einer eingangs zu positionierenden Dir-Schleife, die NUR die Verzeichnisse unterhalb von strFolder einliest (sieh Dir mal die Hilfe von Dir an bzw. überleg Dir standardisierte Verzeichnisnamen, z.B. UV_AbtA, UV_AbtB usw.)
Viel Spaß,
Michael