In 10000 Excel07-Dateien in den immer in der selben Zelle ein Eintrag vorhanden ist sollen bis auf die letzten 6 Zahlen in diesem Feld ersetzt werden.

Basis = "D:\Excel-Dateien Zeichnungen"  
Typ = "xlsx" 'in Kleinbuchstaben  

LogDatei = "D:\Log.csv"  
Delim =";" 'Trennzeichen für Logdatei  

ZNrAdr = "B4" 'Zelle mit Zeichnungsnummer  
ZNrNeu2 = "GS_33_13_" 'Neuer Namensteil für Bauteile  
ZNrNeu3 = "GE_33_13_" 'Neuer Namensteil für Einzelteile  
DatAdr = "H7" ' Zelle für Änderungsdatum  

'Datumsstring für Dateinamen im Format "JJJJ-MM-TT" erstellen  
AktDat = Mid(Date, 7, 4) & "-" & Mid(Date, 4, 2) & "-" & Left(Date, 2)  

Set fso = CreateObject("Scripting.FileSystemObject")  
Set oXL = CreateObject("Excel.Application")  
Set LF = fso.CreateTextFile(LogDatei) 'Logdatei erzeugen  

Set rE = New RegExp
rE.Pattern = "\d{4}-\d{2}-\d{2}" 'Regex-Suchmuster im Format "####-##-##"  

DoSubFolders fso.GetFolder(Basis) 'rekursive Verarbeitung in Basis-Ordner starten  

oXL.Quit
LF.Close
WScript.Echo "Fertig"  

Sub DoSubFolders(Folder)
For Each File In Folder.Files 'alle Dateien des Ordners durchgehen  
    FName = File.Name 'Dateinamen zwischenspeichern  
    'nur Dateien des passenden Typs und solche, die noch nicht bearbeitet wurden  
    If LCase(fso.GetExtensionName(FName)) = Typ And InStr(FName, AktDat) = 0 Then
        Set WB = oXL.Workbooks.Open(File.Path) 'Datei öffnen  

        FNameNeu = rE.Replace(FName, AktDat) 'neuen Namen mit aktuellem Datum erzeugen  
        If FName <> FNameNeu Then 'Dateiname geändert?  
            WB.SaveAs fso.GetParentFolderName(File.Path) & "\" & FNameNeu 'Datei unter neuem Namen speichern  
            Info = File.Path & Delim & FNameNeu 'Dateiinfo für Logdatei erzeugen  
        Else
            Info = File.Path & Delim & "#Dateiname gleich" 'Hinweis auf unveränderten Dateinamen  
        End If

        Set ZN = WB.WorkSheets(1).Range(ZNrAdr) 'Zelle mit Zeichnungsnummer zwischenspeichern  
        Kennung = Right(ZN.Value, 6) 'letzte 6 Stellen der ZNr als Kennung auslesen  
        Select Case Left(Kennung, 1) 'Unterscheidung anhand erster Stelle der Kennung  
        Case "2" 'Bauteil  
            ZNrNeu = ZNrNeu2 & Kennung 'neue Zeichnungsnummer erzeugen ...  
            ZN.Value = ZNrNeu '... und eintragen  
            Info = Info & Delim & ZNrNeu 'Info für Logdatei um neue Zeichnungsnummer ergänzen  
        Case "3" 'Einzelteil  
            ZNrNeu = ZNrNeu3 & Kennung 'neue Zeichnungsnummer erzeugen ...  
            ZN.Value = ZNrNeu '... und eintragen  
            Info = Info & Delim & ZNrNeu 'Info für Logdatei um neue Zeichnungsnummer ergänzen  
        Case Else 'Whatever  
            'Info für Logdatei um Hinweis auf unveränderte Zeichnungsnummer ergänzen  
            Info = Info & Delim & "#Zeichnungsnummer gleich"  
        End Select
		
        WB.WorkSheets(1).Range(DatAdr).Value = Date 'Aktuelles Datum eintragen  
        
        WB.ExportAsFixedFormat 0, fso.GetParentFolderName(File.Path) & "\" & fso.GetBaseName(FNameNeu) & ".pdf" 'PDF erzeugen  
        
		LF.WriteLine Info 'Info in Logdatei schreiben  
        WB.Close True'Datei speichern und schließen  
    End If
Next

For Each SubFolder in Folder.SubFolders 'rekursive Verabeitung der Unterordner  
    DoSubFolders SubFolder
Next
End Sub

WB.ExportAsFixedFormat 0, fso.GetParentFolderName(File.Path) & "\" & fso.GetBaseName(FNameNeu) & ".pdf"