VBA fester Wert in Variable
Hallo Leute,
Ich habe folgendes Problem:
Ich habe eine Excel Datei mit mehreren Tabellenblättern. In diesen Tabellenblättern soll das Datum in Spalte „H“ ab Zeile 10 aktualisiert werden, der Code durch läuft alle Tabellenblätter, die in der Datei sind.
Alter Code ( Teilausschnitt )
For Each Zelle In WkSh_ZB.Sheets(tabReg).Range("H10:H50")
Dieser Code funktioniert einwandfrei!
Nun haben sich aus verschieden Gründen die Tabellenblätter geändert, so dass nicht mehr nur der Bereich H10:H50, sondern auch andere Bereiche nacheinander in „H60: bisH? “ usw. nach unten aktualisiert werden müssen. Die Bereiche werden auch jeweils mit dem Code ermittelt.
Dafür habe ich versucht diesen Code mit Variablen zu verwenden
Neuer Code (Teilausschnitt)
For Each Zelle In WkSh_ZB.Sheets(tabReg).Range(Cells(gefunden, Spalte), Cells(letzteBzeile1, Spalte))
Benutze ich diesen Code bekomme ich den:
Laufzeitfehler 1004
Anwendungs- oder objektdefiniter Fehler
Als Hinwies noch:
Wenn ich in das Tabellenplatt klicke und mit F8 weiter mache läuft der Code durch.
Was im alten Code NICHT SO WAR!
Im Anschluss noch der komplette Code
Sub Testsuchen2(ByVal tabReg As String)
Dim rng As Range
Dim meinbereich As Range
Dim letzteBzeile As Long
Dim jona As Long
Dim Wortgefunden As Long, gefunden As Long
Dim letzteBzeile1 As Long
Dim zeileff As Range, spalteff As Range
Dim Ende As Long
Dim AktuellesDatum As Date, datFrist As Date, datsecond As Date
Dim strWieviel As String
Dim vntFarben As Variant 'Farben
Dim Zelle As Range, c As Range, fz As Range
Dim Zelleeinf As Range
Dim wksTab As Worksheet
Dim liZeile As Integer
Dim lz As Long, lngC As Long, a As Long
Dim Spalte As Integer
'1. Schritt: Finde die letzte beschriebene Zeile
'Finde die letzte beschriebene Zeile im Tabellenblatt im ActivenSheet
'With WkSh_ZB.Sheets(tabReg)
Ende = WkSh_ZB.Sheets(tabReg).Cells.SpecialCells(xlCellTypeLastCell).Row
'MsgBox Ende
letzteBzeile = WkSh_ZB.Sheets(tabReg).Cells(Rows.count, 5).End(xlUp).Row
'MsgBox letzteBzeile
'2. Schritt:
For i = 1 To letzteBzeile
'Suche nach dem Wort im Registerblatt in Spalte A
Set rng = WkSh_ZB.Sheets(tabReg).Cells(i, 1).Find(What:="Wartungsplan", LookIn:=xlValues, lookat:=xlWhole) ', _
'SearchOrder:=xlByRows, SearchDirection:=xlNext)
'Wenn gefunden gib Meldung
If rng Is Nothing Then
'MsgBox "Nichts gefunden"
'Exit Sub
Else
MsgBox "Zeile: " & rng.Row & "; Adresse: " & rng.Address
Wortgefunden = rng.Row
gefunden = rng.Row + 9
'jona = rng.Row + 9
'WkSh_ZB.Sheets(tabReg).Cells(jona, 5).Select
'ActiveSheet.Cells(jona, 5).Select
letzteBzeile1 = WkSh_ZB.Sheets(tabReg).Cells(gefunden, 5).End(xlDown).Row
'WkSh_ZB.Sheets(tabReg).Cells(letzteBzeile1, 5).Select
'gefunden = letzteBzeile1 + 1
'Set meinbereich = .Range(Cells(gefunden, 8), Cells(letzteBzeile1, 8))
Spalte = 8
'Hier wird das Datum Aktuallisiert, die Zellen und das Tabellenblatt eingefärbt
'1.Datum Aktualliesieren
'2.Zellen einfärben
'3.Register einfärben
vntFarben = Array(3, 45, 14, -4105) 'rot, gelb, grün,weiß,standard 2,
AktuellesDatum = Date
'###1.Datum aktuallisieren
'SpalteDurchlaufen
'!!!!!!!Hier bleibt er hängen!!!!!
For Each Zelle In WkSh_ZB.Sheets(tabReg).Range(Cells(gefunden, Spalte), Cells(letzteBzeile1, Spalte))
'Der funzt
'For Each Zelle In WkSh_ZB.Sheets(tabReg).Range("H10:H50")
If Zelle <> "" Then
datfirst = Zelle.Value 'Schreibe in Zelle
strWieviel = Zelle.Offset(0, -2) 'die Anzahl der Monate
If strWieviel > 0 Then
datsecond = DateAdd("m", strWieviel, datfirst) 'DateAdd(Year(datfirst), Month(datfirst) + strWieviel, Day(datafirst))
Zelle.Offset(0, -1) = datsecond
End If
End If
Next
'###2.Zellen einfärben
'SpalteDurchlaufen
For Each Zelleeinf In WkSh_ZB.Sheets(tabReg).Range(Cells(gefunden, 7), Cells(letzteBzeile1, 7)) '("G10:G50")
If Zelleeinf.Offset(0, -1) > 0 Then
If Zelleeinf <> "" Then
If Zelleeinf <= Date Then 'Werte vergleichen
Range(Zelleeinf.Offset(0, -5), Zelleeinf.Offset(0, -3)).Interior.ColorIndex = 3 'Zellen rot einfärben
'Zelle.Offset(0, -4).Interior.ColorIndex = 3 'Zelle rot einfärben
'Zelle.Offset(0, -3).Interior.ColorIndex = 3 'Zelle rot einfärben
Else
Tage = (Zelleeinf - Date) 'Tage berechnen
If Tage <= 7 Then 'Abfrage 7 Tage vorher
Range(Zelleeinf.Offset(0, -5), Zelleeinf.Offset(0, -3)).Interior.ColorIndex = 45 'Zellen gelb einfärben
'Zelle.Offset(0, -4).Interior.ColorIndex = 45 'Zelle gelb einfärben
'Zelle.Offset(0, -3).Interior.ColorIndex = 45 'Zelle gelb einfärben
Else
Range(Zelleeinf.Offset(0, -5), Zelleeinf.Offset(0, -3)).Interior.ColorIndex = xlNone '-4105 'Zellen keine Farbe
'Zelle.Offset(0, -4).Interior.ColorIndex = xlNone '-4105 'Zelle keine Farbe
'Zelle.Offset(0, -3).Interior.ColorIndex = xlNone '-4105 'Zelle keine Farbe
End If
End If
Else
If Zelleeinf.Offset(0, -1) <> "" Then 'wenn in Zelle daneben kein Werte dann
Range(Zelleeinf.Offset(0, -5), Zelleeinf.Offset(0, -3)).Interior.ColorIndex = 3 'Zellen rot einfärben
'Zelle.Offset(0, -4).Interior.ColorIndex = 3 'Zelle rot einfärben
'Zelle.Offset(0, -3).Interior.ColorIndex = 3 'Zelle rot einfärben
End If
End If
End If
Next
Wortgefunden = Wortgefunden + 1
With WkSh_ZB.Sheets(tabReg)
'Registerblatt einfärben
' ###Neu###
'Im TabellenBlatt K2 wird die Farbe eingetragen
lz = IIf(IsEmpty(.Range("B65536")), .Range("B65536").End(xlUp).Row, 65536)
For lngC = 0 To UBound(vntFarben)
An = 10
For Each c In WkSh_ZB.Sheets(tabReg).Range(Cells(gefunden, 2), Cells(letzteBzeile1, 2))
If c.Interior.ColorIndex = vntFarben(lngC) Then
If c.Interior.ColorIndex = -4105 Then GoTo weiter
.Cells(Wortgefunden, 11).Interior.ColorIndex = vntFarben(lngC) 'K2
Exit For
Else
weiter:
If WkSh_ZB.Sheets(tabReg).Cells(Wortgefunden, 11).Interior.ColorIndex = 14 Then
Else
WkSh_ZB.Sheets(tabReg).Cells(Wortgefunden, 11).Interior.ColorIndex = 14 'Zelle grün einfärben
End If
End If
An = An + 1
Next c
If An <= lz Then Exit For 'Prüfen ob c-Schleife abgebrochen wurde
Next lngC
End With
End If
Next i
Stop
'End With
'3. Schritt:
'Set rng = ActiveSheet.Range("A1:A" & letzteBzeile).Find("Wartungsplan")
Set rng = Nothing
End Sub
Was mache ich falsch oder übersehe ich was?
Bitte um HILFE und nicht auf das Netz verweisen, da habe ich schon seit Tagen gesucht und NICHTS gefunden!
Ich habe folgendes Problem:
Ich habe eine Excel Datei mit mehreren Tabellenblättern. In diesen Tabellenblättern soll das Datum in Spalte „H“ ab Zeile 10 aktualisiert werden, der Code durch läuft alle Tabellenblätter, die in der Datei sind.
Alter Code ( Teilausschnitt )
For Each Zelle In WkSh_ZB.Sheets(tabReg).Range("H10:H50")
Dieser Code funktioniert einwandfrei!
Nun haben sich aus verschieden Gründen die Tabellenblätter geändert, so dass nicht mehr nur der Bereich H10:H50, sondern auch andere Bereiche nacheinander in „H60: bisH? “ usw. nach unten aktualisiert werden müssen. Die Bereiche werden auch jeweils mit dem Code ermittelt.
Dafür habe ich versucht diesen Code mit Variablen zu verwenden
Neuer Code (Teilausschnitt)
For Each Zelle In WkSh_ZB.Sheets(tabReg).Range(Cells(gefunden, Spalte), Cells(letzteBzeile1, Spalte))
Benutze ich diesen Code bekomme ich den:
Laufzeitfehler 1004
Anwendungs- oder objektdefiniter Fehler
Als Hinwies noch:
Wenn ich in das Tabellenplatt klicke und mit F8 weiter mache läuft der Code durch.
Was im alten Code NICHT SO WAR!
Im Anschluss noch der komplette Code
Sub Testsuchen2(ByVal tabReg As String)
Dim rng As Range
Dim meinbereich As Range
Dim letzteBzeile As Long
Dim jona As Long
Dim Wortgefunden As Long, gefunden As Long
Dim letzteBzeile1 As Long
Dim zeileff As Range, spalteff As Range
Dim Ende As Long
Dim AktuellesDatum As Date, datFrist As Date, datsecond As Date
Dim strWieviel As String
Dim vntFarben As Variant 'Farben
Dim Zelle As Range, c As Range, fz As Range
Dim Zelleeinf As Range
Dim wksTab As Worksheet
Dim liZeile As Integer
Dim lz As Long, lngC As Long, a As Long
Dim Spalte As Integer
'1. Schritt: Finde die letzte beschriebene Zeile
'Finde die letzte beschriebene Zeile im Tabellenblatt im ActivenSheet
'With WkSh_ZB.Sheets(tabReg)
Ende = WkSh_ZB.Sheets(tabReg).Cells.SpecialCells(xlCellTypeLastCell).Row
'MsgBox Ende
letzteBzeile = WkSh_ZB.Sheets(tabReg).Cells(Rows.count, 5).End(xlUp).Row
'MsgBox letzteBzeile
'2. Schritt:
For i = 1 To letzteBzeile
'Suche nach dem Wort im Registerblatt in Spalte A
Set rng = WkSh_ZB.Sheets(tabReg).Cells(i, 1).Find(What:="Wartungsplan", LookIn:=xlValues, lookat:=xlWhole) ', _
'SearchOrder:=xlByRows, SearchDirection:=xlNext)
'Wenn gefunden gib Meldung
If rng Is Nothing Then
'MsgBox "Nichts gefunden"
'Exit Sub
Else
MsgBox "Zeile: " & rng.Row & "; Adresse: " & rng.Address
Wortgefunden = rng.Row
gefunden = rng.Row + 9
'jona = rng.Row + 9
'WkSh_ZB.Sheets(tabReg).Cells(jona, 5).Select
'ActiveSheet.Cells(jona, 5).Select
letzteBzeile1 = WkSh_ZB.Sheets(tabReg).Cells(gefunden, 5).End(xlDown).Row
'WkSh_ZB.Sheets(tabReg).Cells(letzteBzeile1, 5).Select
'gefunden = letzteBzeile1 + 1
'Set meinbereich = .Range(Cells(gefunden, 8), Cells(letzteBzeile1, 8))
Spalte = 8
'Hier wird das Datum Aktuallisiert, die Zellen und das Tabellenblatt eingefärbt
'1.Datum Aktualliesieren
'2.Zellen einfärben
'3.Register einfärben
vntFarben = Array(3, 45, 14, -4105) 'rot, gelb, grün,weiß,standard 2,
AktuellesDatum = Date
'###1.Datum aktuallisieren
'SpalteDurchlaufen
'!!!!!!!Hier bleibt er hängen!!!!!
For Each Zelle In WkSh_ZB.Sheets(tabReg).Range(Cells(gefunden, Spalte), Cells(letzteBzeile1, Spalte))
'Der funzt
'For Each Zelle In WkSh_ZB.Sheets(tabReg).Range("H10:H50")
If Zelle <> "" Then
datfirst = Zelle.Value 'Schreibe in Zelle
strWieviel = Zelle.Offset(0, -2) 'die Anzahl der Monate
If strWieviel > 0 Then
datsecond = DateAdd("m", strWieviel, datfirst) 'DateAdd(Year(datfirst), Month(datfirst) + strWieviel, Day(datafirst))
Zelle.Offset(0, -1) = datsecond
End If
End If
Next
'###2.Zellen einfärben
'SpalteDurchlaufen
For Each Zelleeinf In WkSh_ZB.Sheets(tabReg).Range(Cells(gefunden, 7), Cells(letzteBzeile1, 7)) '("G10:G50")
If Zelleeinf.Offset(0, -1) > 0 Then
If Zelleeinf <> "" Then
If Zelleeinf <= Date Then 'Werte vergleichen
Range(Zelleeinf.Offset(0, -5), Zelleeinf.Offset(0, -3)).Interior.ColorIndex = 3 'Zellen rot einfärben
'Zelle.Offset(0, -4).Interior.ColorIndex = 3 'Zelle rot einfärben
'Zelle.Offset(0, -3).Interior.ColorIndex = 3 'Zelle rot einfärben
Else
Tage = (Zelleeinf - Date) 'Tage berechnen
If Tage <= 7 Then 'Abfrage 7 Tage vorher
Range(Zelleeinf.Offset(0, -5), Zelleeinf.Offset(0, -3)).Interior.ColorIndex = 45 'Zellen gelb einfärben
'Zelle.Offset(0, -4).Interior.ColorIndex = 45 'Zelle gelb einfärben
'Zelle.Offset(0, -3).Interior.ColorIndex = 45 'Zelle gelb einfärben
Else
Range(Zelleeinf.Offset(0, -5), Zelleeinf.Offset(0, -3)).Interior.ColorIndex = xlNone '-4105 'Zellen keine Farbe
'Zelle.Offset(0, -4).Interior.ColorIndex = xlNone '-4105 'Zelle keine Farbe
'Zelle.Offset(0, -3).Interior.ColorIndex = xlNone '-4105 'Zelle keine Farbe
End If
End If
Else
If Zelleeinf.Offset(0, -1) <> "" Then 'wenn in Zelle daneben kein Werte dann
Range(Zelleeinf.Offset(0, -5), Zelleeinf.Offset(0, -3)).Interior.ColorIndex = 3 'Zellen rot einfärben
'Zelle.Offset(0, -4).Interior.ColorIndex = 3 'Zelle rot einfärben
'Zelle.Offset(0, -3).Interior.ColorIndex = 3 'Zelle rot einfärben
End If
End If
End If
Next
Wortgefunden = Wortgefunden + 1
With WkSh_ZB.Sheets(tabReg)
'Registerblatt einfärben
' ###Neu###
'Im TabellenBlatt K2 wird die Farbe eingetragen
lz = IIf(IsEmpty(.Range("B65536")), .Range("B65536").End(xlUp).Row, 65536)
For lngC = 0 To UBound(vntFarben)
An = 10
For Each c In WkSh_ZB.Sheets(tabReg).Range(Cells(gefunden, 2), Cells(letzteBzeile1, 2))
If c.Interior.ColorIndex = vntFarben(lngC) Then
If c.Interior.ColorIndex = -4105 Then GoTo weiter
.Cells(Wortgefunden, 11).Interior.ColorIndex = vntFarben(lngC) 'K2
Exit For
Else
weiter:
If WkSh_ZB.Sheets(tabReg).Cells(Wortgefunden, 11).Interior.ColorIndex = 14 Then
Else
WkSh_ZB.Sheets(tabReg).Cells(Wortgefunden, 11).Interior.ColorIndex = 14 'Zelle grün einfärben
End If
End If
An = An + 1
Next c
If An <= lz Then Exit For 'Prüfen ob c-Schleife abgebrochen wurde
Next lngC
End With
End If
Next i
Stop
'End With
'3. Schritt:
'Set rng = ActiveSheet.Range("A1:A" & letzteBzeile).Find("Wartungsplan")
Set rng = Nothing
End Sub
Was mache ich falsch oder übersehe ich was?
Bitte um HILFE und nicht auf das Netz verweisen, da habe ich schon seit Tagen gesucht und NICHTS gefunden!
mfg
Michael
:98:
WIN 10 Office 2019
Michael
:98:
WIN 10 Office 2019
