• Úvod
• Excel návod
• Excel šablony
• Nástěnka
• Mobility
• Tipy na výlet
• Galerie
• Fórum

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?

Zaslat odpověď >

---

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 Subcitovat

JoKe(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

elninoslov(12.4.2023 0:55)#054782

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

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse