Typen unverträglichkeit
05.09.2023 08:25:16
Mathias221
Ich habe eine Excel Tabelle hier bin ich dank Piet, volti und Thorsten schon sehr weit gekommen vielen dank nochmal dafür, aber ich hänge schon wieder leider.
Und zwar bekomme ich es nicht hin in dem Code in Datei Dienstantritte das er das suchwort welches er zu vor gefunden hat weiter benutzt.
https://ddownload.com/wjoj0mrncs0w/Dienstantritte.xlsm
https://ddownload.com/jxlnbu8wzf65/Dienstplan_Weapons.xlsm
https://ddownload.com/fgtrgbd9p6no/Backup.zip
Der Code an sich sollte so funktionieren aber er schmeißt mir immer eine Typen unverträglichkeit oder wenn ich ihn ein wenig ändere einfach Fehler 400 raus.
Option Explicit
Sub Okay()
'ich deklariere gern alle Variablen dort, wo sie im Einsatz sind; wenn du das so nicht möchtest, kannst du das wieder rückgängig machen
Dim liIdx As Integer
Dim Assets As Variant
Dim Asset As Variant
Dim strSuchwort As String
Dim lboRepeat As Boolean, lrgSearch As Range
Dim lrgCell As Range
Dim Stamm_wb As Workbook
Dim Quell_wb As Workbook
Dim st_Dienst_sh As Worksheet
Dim MyRange As Range, such_rng As Range
Dim Verzeichnis As String
Dim Verzeichnis2 As String
Dim Erweiterung As String
Dim lwbAll As Workbook, lwbWaffeB As Workbook, lboIsOpen As Boolean, lshWaffeB As Worksheet, lboExist As Boolean
Dim lrgFind As Range, firstAddress As String
Dim lstrPerson As String
Dim lstrLogin As String
Dim lloRow As Long
Application.DisplayStatusBar = True
Application.StatusBar = ">>>>>>>>>>>>>>>>>>>> Daten werden aktualisiert. Bitte warten! "
Verzeichnis = "I:\Lw\218407\31-5620-E-WacheDPLEssMeld\01 Dienstplan\011 Jahresdienstplan\Backup\" 'Ablageort der Quelldatei anpassen
Verzeichnis2 = "I:\Lw\218407\31-5620-E-WacheDPLEssMeld\01 Dienstplan\011 Jahresdienstplan\" 'Ablageort der Quelldatei anpassen
Set Stamm_wb = Application.ActiveWorkbook
Set st_Dienst_sh = Stamm_wb.Worksheets("Dienstantritte")
Set Quell_wb = Application.Workbooks.Open(Verzeichnis2 & ("Dienstplan Weapons.xlsm"), Password:="sunhawk")
lstrLogin = Environ("username")
With Sheets("Pers")
For lloRow = 3 To .Cells(.Rows.Count, 1).End(xlUp).Row
If lstrLogin = .Range("AL" & lloRow).Value Then
lstrPerson = .Range("A" & lloRow).Value
Exit For
End If
Next
End With
Erweiterung = st_Dienst_sh.Cells(7, 33)
Asset = Array("Januar " & Erweiterung, _
"Februar " & Erweiterung, _
"März " & Erweiterung, _
"April " & Erweiterung, _
"Mai " & Erweiterung, _
"Juni " & Erweiterung, _
"Juli " & Erweiterung, _
"August " & Erweiterung, _
"September " & Erweiterung, _
"Oktober " & Erweiterung, _
"November " & Erweiterung, _
"Dezember " & Erweiterung)
If lboRepeat = False Then
With st_Dienst_sh
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
End With
End If
For liIdx = 0 To 11
'wenn Monatsdatei im Verzeichnis Backup vorhanden, dann...
If Dir(Verzeichnis & Asset(liIdx) & ".xls") > "" Then
Set Quell_wb = Workbooks.Open(Verzeichnis & Asset(liIdx) & ".xls", , 1)
strSuchwort = lstrPerson & " (33)"
Set lrgFind = Workbooks(Quell_wb).Worksheets(Asset(liIdx)).Range("C:C").Find(strSuchwort)
If Not lrgFind Is Nothing Then
With st_Dienst_sh
Quell_wb.Worksheets(Asset(liIdx)).Range("A10:AJ11").Copy
.Range("A" & .Cells(.Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial xlPasteAll
End With
firstAddress = lrgFind.Address
Do
lrgFind.EntireRow.Copy st_Dienst_sh.Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1)
st_Dienst_sh.Range("B" & Cells(Rows.Count, 1).End(xlUp).Row).Value = "'" & Asset(liIdx) 'kannst du wieder löschen! in jeder Datenzeile wird hier in Spalte B jeweils der Monat eingetragen, aus dem diese Datenzeile kopiert wurde --> nur für mich als Übersicht, damit ich auch sehen kann, dass wirklich die richtigen Daten kopiert + eingefügt werden
Set lrgFind = Quell_wb.Worksheets(Asset(liIdx)).Range("C:C").FindNext(lrgFind)
Loop While Not lrgFind Is Nothing And lrgFind.Address > firstAddress
End If
Application.CutCopyMode = False
Quell_wb.Close 0
'wenn Monatsdatei im Verzeichnis Backup NICHT vorhanden, dann...AB HIER kommt DER TEIL
Else
If lboIsOpen = False Then
For Each lwbAll In Workbooks
If lwbAll.Name = "Dienstplan Weapons.xlsm" Then
lboIsOpen = True
Exit For
End If
Next
If lboIsOpen = False Then
'Achtung!!! da ich nich weiß, in welchem Verzeichnis bei dir die Datei "Dienstplan Weapons.xlsm" gespeichert ist,
'befindet sich die Datei bei mir erst mal genau dort, wo auch die Datei gespeichert ist, in dem gerade dieses Makro abläuft
'- Für meine Testumgebung muss die folgende Codezeile so bleiben - Wenn bei dir (Original-Umgebung) die Datei woanders gespeichert ist, dann musst du den Teil >>>ThisWorkbook.Path entsprechend anpassen
Set lwbWaffeB = Application.Workbooks.Open(Verzeichnis2 & ("Dienstplan Weapons.xlsm"), Password:="sunhawk")
lboIsOpen = True
End If
End If
strSuchwort = lstrPerson
For Each lshWaffeB In lwbWaffeB.Sheets
If LCase(lshWaffeB.Name) = LCase(Asset(liIdx)) Then
lboExist = True
Exit For
End If
Next
If lboExist = True Then
lboIsOpen = False
Set lrgFind = lwbWaffeB.Worksheets(Asset(liIdx)).Range("C:C").Find(strSuchwort)
If Not lrgFind Is Nothing Then
With st_Dienst_sh
lwbWaffeB.Worksheets(Asset(liIdx)).Range("A10:AJ11").Copy
.Range("A" & .Cells(.Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial xlPasteAll
End With
firstAddress = lrgFind.Address
Do
lrgFind.EntireRow.Copy st_Dienst_sh.Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1)
st_Dienst_sh.Range("B" & Cells(Rows.Count, 1).End(xlUp).Row).Value = "'" & Asset(liIdx) 'kannst du wieder löschen! in jeder Datenzeile wird hier in Spalte B jeweils der Monat eingetragen, aus dem diese Datenzeile kopiert wurde --> nur für mich als Übersicht, damit ich auch sehen kann, dass wirklich die richtigen Daten kopiert + eingefügt werden
Set lrgFind = lwbWaffeB.Worksheets(Asset(liIdx)).Range("C:C").FindNext(lrgFind)
Loop While Not lrgFind Is Nothing And lrgFind.Address > firstAddress
End If
Application.CutCopyMode = False
End If
End If
Next
'die zuvor geöffnete Hauptdatei wird nun wieder geschlossen
If Not lwbWaffeB Is Nothing Then
lwbWaffeB.Close False
End If
With st_Dienst_sh
Set MyRange = .Range("A11:AJ46")
For Each lrgCell In MyRange
If lrgCell.Interior.Pattern = xlPatternLightHorizontal Or _
lrgCell.Interior.Pattern = xlPatternSemiGray75 Or _
lrgCell.Interior.Pattern = xlPatternGray75 Then
lrgCell.ClearContents
End If
Next
.Cells.Locked = True
MyRange.Locked = False
.Range("AF8").UnMerge
With .Range("AF8:AG9")
.Locked = False
.Merge
End With
.Protect "test"
End With
With Application
.ScreenUpdating = True
.StatusBar = ""
.DisplayStatusBar = False
.DisplayAlerts = False
End With
Set Stamm_wb = Nothing
Set st_Dienst_sh = Nothing
Set Quell_wb = Nothing
Set lwbWaffeB = Nothing
Set MyRange = Nothing
End Sub
Ich hoffe jemand kann mir helfen
Danke
Gruß Mathias