Inhalte in alle Dateien kopieren
08.03.2023 12:56:07
Christian
ich habe 2 Herausforderungen:
1. Ich möchte aus einer Datei, die geöffnet ist, den Bereich C3:C51 kopieren und automatisch in alle Dateien in diesem Verzeichnis (C:\Test) kopieren (alle Dateien haben dieselbe Datenstruktur und das Sheet Tabelle1).
2. Ich möchte aus derselben Datei, die geöffnet ist, die bedingte Formatierung, die in den Zellen D3:D51 ist, automatisch in alle Dateien in diesem Verzeichnis (C:\Test) übertragen (alle Dateien haben dieselbe Datenstruktur und das Sheet Tabelle1).
Das können auch 2 unterschiedliche Schritte sein.
Erweitert ist die Frage, ob ich das auch auf alle Dateien in den Unterverzeichnissen ausdehnen kann?
Ich habe bereits einen Code vorliegen, mit dem ich bei allen Dateien in dem Verzeichnis und Unterverzeichnissen den Passwortschutz aufgehoben habe.
Vielleicht kann man diesen Code verwenden und nur anpassen?
Vielen Dank für eure Unterstützung
Hier der Code, den ich verwendet habe (das tatsächliche Passwort ist anders):
Option Explicit
Private Declare Function SHGetFileInfo Lib "Shell32" Alias "SHGetFileInfoA" (ByVal pszPath As Any, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Const MAX_PATH = 260
Private Const SHGFI_TYPENAME = &H400&
Private Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
Public Enum SORT_BY
Sort_by_None
Sort_by_Name
Sort_by_Path
Sort_by_Size
Sort_by_Last_Access
Sort_by_Last_Modyfy
Sort_by_Date_Create
End Enum
Public Enum SORT_ORDER
Sort_Order_Ascending
Sort_Order_Descending
End Enum
Public Type FILEINFO
strFilename As String
strPath As String
lngSize As Long
dmtLastAccess As Date
dmtLastModify As Date
dmtDateCreate As Date
End Type
Sub schutzAn()
protectAllSheets ""C:\Test", "DeinPasswort", True
End Sub
Sub schutzAus()
protectAllSheets "C:\Test", "DeinPasswort", False
End Sub
Sub protectAllSheets(Directory As String, Password As String, Protection As Boolean)
Dim objFileSearch As clsFileSearch
Dim objWB As Workbook, objSH As Worksheet
Dim strFile As String, strDir As String
Dim lngCalc As Long, lngIndex As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFileSearch = New clsFileSearch
With objFileSearch
.CaseSenstiv = False
.Extension = "*.xls*"
.FolderPath = Directory
.SearchLike = "*"
.SubFolders = True
If .Execute() > 0 Then
For lngIndex = 1 To .FileCount
If LCase(.Files(lngIndex).strPath) > LCase(ThisWorkbook.FullName) And Not .Files(lngIndex).strPath Like "*~$*" Then
Application.StatusBar = "Bearbeite Datei " & lngIndex & " von " & .FileCount
Set objWB = Workbooks.Open(.Files(lngIndex).strPath, UpdateLinks:=False)
For Each objSH In objWB.Worksheets
If Protection Then
objSH.Protect Password
Else
objSH.Unprotect Password
End If
Next
objWB.Close True
End If
Next
End If
End With
ErrExit:
With Err
If .Number > 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'protectAllSheets'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Modul1"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
.StatusBar = False
End With
Set objWB = Nothing
Set objSH = Nothing
End Sub