AW: Batch-Änderung an mehreren Excel-Dokumenten
28.10.2013 16:33:29
Tino
Hallo,
kannst mal diesen Code versuchen (aber erst Testen)
Erstelle eine Neue Exceldatei und stell den Code in ein Modul.
Sub Start()
Dim ArFile(), n&, Anzahl&, sDir$
Dim sPath$
Dim newApp As Application
'Zu ändernde Daten
Const strTabelle As String = "Tabelle1"
Const strZelle As String = "B5"
Const NewWert As Variant = 15
'Pfad anpassen
sPath = "C:\User1\Dokumente\"
sPath = IIf(Right$(sPath, 1) = "\", sPath, sPath & "\")
sDir = Dir(sPath & "*.xls*", vbNormal)
Do While sDir ""
n = n + 1
ReDim Preserve ArFile(1 To 3, 1 To n)
ArFile(1, n) = sPath & sDir
ArFile(2, n) = sDir
sDir = Dir()
Loop
If n > 0 Then
Anzahl = UBound(ArFile, 2)
Set newApp = New Application
With newApp
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
For n = LBound(ArFile, 2) To UBound(ArFile, 2)
Application.StatusBar = "Ändere Datei " & n & " von " & Anzahl
With .Workbooks.Open(ArFile(1, n))
If Not .ReadOnly Then
.Sheets(strTabelle).Range(strZelle).Value = NewWert
ArFile(3, n) = "ok"
Else
ArFile(3, n) = "Schreibgeschützt"
End If
.Close Not .ReadOnly
End With
Next n
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Quit
End With
End If
Application.StatusBar = False
'Ausgabe Info
With Tabelle1
.UsedRange.Clear
.Cells(1, 1) = "Datei"
.Cells(1, 2) = "Info"
.UsedRange.Rows(1).Font.Bold = True
If n > 0 Then
ArFile = Application.Transpose(ArFile)
With .Range("A2").Resize(UBound(ArFile), 2)
.Columns(1).Value = Application.Index(ArFile, , 2)
.Columns(2).Value = Application.Index(ArFile, , 3)
End With
Else
MsgBox "Es wurden keine Datei gefunden!", vbExclamation
End If
.UsedRange.EntireColumn.AutoFit
End With
End Sub
Gruß Tino