AW: cool! Glückwunsch!
17.07.2023 17:36:41
wolgertal
Hallo Herbert, ja, das habe ich falsch verstanden.
Hier der geänderte Code, viele Grüße Ulli
Option Explicit
' Suchmuster gegebenenfalls anpassen
Const strEX As String = "*.xls*"
Public Sub Zelländerung()
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
Dim picBild As Picture
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)
Call wkbBook.Worksheets(1).Unprotect(Password:="4711")
.Range("H10").Value = "Taris Beck"
.Range("H10").Font.Size = 15
.Range("H10").VerticalAlignment = xlCenter
.Range("B9").Value = ""
For Each picBild In ActiveSheet.Pictures ' Bild löschen in Zelle
If Not Intersect(picBild.TopLeftCell, Range("H10")) Is Nothing Then picBild.Delete
Next picBild
.Parent.Close True
'Call Tabelle1.Protect(Password:="4711", UserInterfaceOnly:=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