Rem hier mit Zeile 1 der aktiven Tabelle überschreiben
Rem vgl. <<<<<<<
Option Explicit
Sub DateienNachOrdner()
Rem Sub DateiÄndern
Dim oStack As Object
Dim objFso As Object
Dim fldStart As Object
Dim fl As Object
Dim arrRow()
Dim strPop As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error GoTo DateienNachListe_Error
arrRow = Range("A1: AZ1")
Cells.ClearContents
Range("A1").Resize(UBound(arrRow, 1), UBound(arrRow, 2)).Value = arrRow
Set objFso = CreateObject("scripting.FileSystemObject")
Set fldStart = objFso.GetFolder("c:\testdaten")
Set oStack = CreateObject("System.Collections.Stack")
For Each fl In fldStart.Files
If InStr(fl.Name, Chr(126)) = 0 Then
If fl.Name Like "*.xls?" Then _
oStack.Push fl.Path
End If
Next fl
Do
strPop = oStack.pop
DateiÄndern strPop, arrRow
Loop
On Error GoTo 0
DateienNachListe_Error:
Select Case Err.Number
Case Is = 0:
Case Is = -2146233079
Case Else
Do While Workbooks.Count > 1
Workbooks(Workbooks.Count).Close savechanges:=False
Loop
Select Case MsgBox("offene Liste speichern ?", _
vbYesNo Or vbCritical Or vbDefaultButton1, _
"Abbruch bei " & strPop)
Case vbYes
arrRow = oStack.ToArray
Cells(2, 5).Value = strPop
Cells(3, 5).Resize(UBound(arrRow)).Value = _
Application.Transpose(arrRow)
Case vbNo
End Select
End Select
Set objFso = Nothing
Set fldStart = Nothing
Set oStack = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Private Sub DateiÄndern(strFile As String, arrNew As Variant)
Dim oWb As Workbook
Set oWb = Workbooks.Open(strFile)
With Sheets("PQ")
.Range("A1").Resize(UBound(arrNew, 1), _
UBound(arrNew, 2)).Value = arrNew
End With
oWb.Close savechanges:=True
Cells(Rows.Count, 1).End(xlUp).Offset(1).Value = strFile
End Sub