eine Zelle in mehreren Dateien ändern

Sub DateienVerarbeiten() Dim i As Long Dim Blatt As Worksheet Const verz = "D:\Eigene Dateien\" On Error GoTo fehler ChDir verz With Application.FileSearch .NewSearch .LookIn = verz .SearchSubFolders = False .FileType = msoFileTypeExcelWorkbooks .Execute For i = 1 To .FoundFiles.Count Workbooks.Open .FoundFiles(i) For Each Tabelle In ActiveWorkbook.Worksheets Tabelle.Range("A1").Value = "TEXTNEU" Next Tabelle ActiveWorkbook.Close savechanges:=True Next i End With Exit Sub fehler: MsgBox "Es gibt kein Verzeichnis mit dem Namen " & verz End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo, :-)
... das so machen: ;-)

Option Explicit
' Suchmuster gegebenenfalls anpassen
Const strEX As String = "*.xls*"
Public Sub Main()
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
Dim lngCalc As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Datei im gleichen Ordner wie Auswertungsdateien
' strDir = ThisWorkbook.Path & "\"
' Fester Ordner vorgegeben
strDir = "C:\Temp\Test\"
strDir = IIf(Right(strDir, 1)  "\", strDir & "\", strDir)
Set objDir = objFSO.getfolder(strDir)
'dirInfo objDir, strEX, True ' Mit Unterordner
dirInfo objDir, strEX ' Ohne Unterordner
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
Set objDir = Nothing
Set objFSO = Nothing
If Err.Number  0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
Dim wkbBook As Workbook
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName Then
If varTMP.Name  ThisWorkbook.Name Then
If Left(varTMP.Name, 1)  "~" Then
Set wkbBook = Workbooks.Open(varTMP.Path)
' Zweites Tabellenblatt - Index 2
With wkbBook.Worksheets(1)
.Range("B1").Value = "Neu"
.Range("B2").Value = "AuchNeu"
.Parent.Close True
Set wkbBook = Nothing
End With
End If
End If
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, blnTMP
Next varTMP
End If
Set wkbBook = Nothing
End Sub

Im Moment wird im Pfad "C:\Temp\Test\" im zweiten Tabellenblatt in Zelle "B1" und "B2" geändert.
Servus
Case

Beliebteste Forumthreads (12 Monate)

eine Zelle in mehreren Dateien ändern

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread