< návrat zpět
MS Excel
Téma: Run time error 1004 
Zaslal/a Ridder 11.4.2023 14:59
Zdravím,
makra vůbec neumím a toto mi vytvořil ChatGPT. Problém je, že mi to stále hází run time error 1004 method range of object _worksheet failed
Private Sub Worksheet_Change(ByVal Target As Range)
Dim testValue As Variant
Dim myRange As Range
Set myRange = Range("D8:D372")
If Target.Cells.Count > 1 Then Exit Sub 'ignoruje změny s více než jednou buňkou
If Intersect(Target, myRange) Is Nothing Then Exit Sub 'ignoruje změny mimo určený rozsah
testValue = Target.Value
If IsNumeric(testValue) Then
If testValue >= 0 And testValue < 1 Then
Target.Value = Format(testValue, "h:mm")
ElseIf testValue >= 1 And testValue < 24 Then
If Int(testValue) = testValue Then
Target.Value = Format(testValue, "0") & ":00"
Else
Target.Value = Format(testValue, "h:mm")
End If
End If
End If
End Sub
Pokud bych chtěl, aby makro fungovalo pouze ve sloupci E, tak je kód
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub 'ignoruje změny s více než jednou buňkou
If Target.Column <> 5 Then Exit Sub 'ignoruje změny mimo sloupec E
Dim testValue As Variant
testValue = Target.Value
If IsNumeric(testValue) Then
If testValue >= 0 And testValue < 1 Then
Target.Value = Format(testValue, "h:mm")
ElseIf testValue >= 1 And testValue < 24 Then
If Int(testValue) = testValue Then
Target.Value = Format(testValue, "0") & ":00"
Else
Target.Value = Format(testValue, "h:mm")
End If
End If
End If
End Sub
A ten funguje dokonale. Kde je prosím chyba pokud potřebuji, aby makro fungovalo v D8:D372?
Dingo(11.4.2023 15:47)#054780 
Testoval jsem a funguje mi tento kód:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim testValue As Variant
If Target.Cells.Count > 1 Then Exit Sub 'ignoruje zmìny s více než jednou buòkou
If Intersect(Target, Range(Cells(8, 4), Cells(372, 4))) Is Nothing Then Exit Sub 'ignoruje zmìny mimo urèený rozsah
testValue = Target.Value
If IsNumeric(testValue) Then
If testValue >= 0 And testValue < 1 Then
Target.Value = Format(testValue, "h:mm")
ElseIf testValue >= 1 And testValue < 24 Then
If Int(testValue) = testValue Then
Target.Value = Format(testValue, "0") & ":00"
Else
Target.Value = Format(testValue, "h:mm")
End If
End If
End If
End SubcitovatJoKe(11.4.2023 18:52)#054781 &Ridder
kód je zacyklený.
Změna v buňce vyvolá běh kódu, který v buňce provede požadovanou změnu, ale tato změna spustí kód znovu.
citovat
Urobte si dočasné odstavenie Events, napr.:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim testValue As Variant
Dim myRange As Range
Dim myChangedRNG As Range
Set myRange = Range("D8:D372")
Set myChangedRNG = Intersect(Target, myRange)
If myChangedRNG Is Nothing Then Exit Sub 'ignoruje změny mimo určený rozsah
If myChangedRNG.Cells.Count > 1 Then Exit Sub 'ignoruje změny s více než jednou buňkou
testValue = myChangedRNG.Value
If IsNumeric(testValue) Then
Application.EnableEvents = False
On Error GoTo KONIECTESTU
If testValue >= 0 And testValue < 1 Then
myChangedRNG.Value = Format(testValue, "h:mm")
ElseIf testValue >= 1 And testValue < 24 Then
If Int(testValue) = testValue Then
myChangedRNG.Value = Format(testValue, "0") & ":00"
Else
myChangedRNG.Value = Format(testValue, "h:mm")
End If
End If
KONIECTESTU:
On Error GoTo 0
Application.EnableEvents = True
End If
End Subcitovat
RSS nejnovější články