denn mit einem Freeware-Editor hattu ab Office 2007 schlechte Karten!
Hier hab ich was für deinen Zweck "umgestrickt" - 100 Files in schlappen 20 sec.
Gruß (und vergiss nicht deine Daten zu sichern)
'******************************************************************************
' Modul: Modul1 / erstellt : 27.04.2014
'------------------------------------------------------------------------------
' Zweck / Inhalt :
' alle Dateien *.xls? im vorgegebenen Ordner
' auflisten
' öffnen
' ändern
Rem hier mit Zeile 1 der aktiven Tabelle überschreiben
Rem vgl. <<<<<<<
' speichern
' Ergebnisliste in Spalte 1
' Restliste im Fehlerfall in Spalte 5
'******************************************************************************
Option Explicit
'
Sub DateienNachOrdner()
'
'******************************************************************************
' Name : DateienNachListe / erstellt : 27.04.2014 / 08:28 / Sub
'------------------------------------------------------------------------------
' ggf. Liste leeren (ab Zeile 2 der aktiven Tabelle)
' Dateiliste auf Stack
' loop until Stack empty Error
Rem Sub DateiÄndern
'******************************************************************************
'
Dim oStack As Object 'File Stack
Dim objFso As Object 'FileSystemObject
Dim fldStart As Object 'Folder
Dim fl As Object 'Element
Dim arrRow() 'Array
Dim strPop As String 'Stack Pop
'
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: 'errorless
Case Is = -2146233079 'empty stack
Case Else 'display
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
|