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