ich habe eine Datei welche aus unserem Dienstplan die einzelnen Zeilen für jeden perönlich auflistet und nun ist das Problem, dass unser Dienstplaner die Monate aufgrund von Datei größe entfernt hat.
Allerdings gibt es ein Backup in einem anderen Ordner.
Ist es möglich den Ablagort der Quelldatei bei Fehler 9 also wenn er zum Beispiel das Tabellenblatt "Januar 22" nicht findet so zu ändern das er in den Ordner \Bakup\2022 geht und dort den Dienstplan 2022.xlsm öffnet?
Leider ändert sich bei mir dann auch gleich der Dateiname, hier kommt dann auch noch das Jahr dazu.
Sub Okay()
Stamm = Application.ActiveWorkbook.Name
Quelldatei = "Dienstplan.xlsm" 'Dateiname anpassen
Sheets("Dienstantritte").Unprotect "test"
Sheets("Dienstantritte").Cells.Range("A11:BA5000").Clear
strSuchwort = UserForm1.ComboBox1.Value
Workbooks.Open Filename:="I:\218407\31-5620-E-WacheDPLEssMeld\01 Dienstplan\011 Jahresdienstplan\" & Quelldatei 'Ablageort der Quelldatei anpassen
Assets = Array("Januar " & Workbooks(Stamm).Sheets("Dienstantritte").Cells(7, 33), _
"Februar " & Workbooks(Stamm).Worksheets("Dienstantritte").Cells(7, 33), _
"März " & Workbooks(Stamm).Worksheets("Dienstantritte").Cells(7, 33), _
"April " & Workbooks(Stamm).Worksheets("Dienstantritte").Cells(7, 33), _
"Mai " & Workbooks(Stamm).Worksheets("Dienstantritte").Cells(7, 33), _
"Juni " & Workbooks(Stamm).Worksheets("Dienstantritte").Cells(7, 33), _
"Juli " & Workbooks(Stamm).Worksheets("Dienstantritte").Cells(7, 33), _
"August " & Workbooks(Stamm).Worksheets("Dienstantritte").Cells(7, 33), _
"September " & Workbooks(Stamm).Worksheets("Dienstantritte").Cells(7, 33), _
"Oktober " & Workbooks(Stamm).Worksheets("Dienstantritte").Cells(7, 33), _
"November " & Workbooks(Stamm).Worksheets("Dienstantritte").Cells(7, 33), _
"Dezember " & Workbooks(Stamm).Worksheets("Dienstantritte").Cells(7, 33))
'On Error GoTo ErrorHandler
For Each Asset In Assets
Workbooks(Quelldatei).Sheets(Asset).Range("A10:AJ11").Copy ' Blatt/Bereich anpassen
Workbooks(Stamm).Sheets("Dienstantritte").Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial xlPasteAll ' Blatt/Bereich anpassen
For Each rngZelle In Workbooks(Quelldatei).Sheets(Asset).Range("C:C")
If rngZelle = strSuchwort Then
rngZelle.EntireRow.Copy
Workbooks(Stamm).Sheets("Dienstantritte").Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial xlPasteAll
End If
Next
Next
Application.CutCopyMode = False
Workbooks(Quelldatei).Close
Set MyRange = Range("A11:AJ46")
For Each Cell In MyRange
If Cell.Interior.Pattern = xlPatternLightHorizontal Then
Cell.ClearContents
End If
If Cell.Interior.Pattern = xlPatternSemiGray75 Then
Cell.ClearContents
End If
Next Cell
Cells.Select
Range("A1").Activate
Selection.Locked = True
Range("A11:AJ46").Select
Selection.Locked = False
Range("AF8").Select
Selection.Locked = False
Worksheets("Dienstantritte").Protect "test"
Unload UserForm1
'ErrorHandler:
End Sub
vieln dank für eure hilfe