< návrat zpět

MS Excel


Téma: Run time error 1004 rss

Zaslal/a 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ěď >

#054780
avatar
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 Sub
citovat
#054781
avatar
&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
#054782
elninoslov
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 Sub
citovat

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

On-line nástroje

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Aktivní diskuse

rozlisna tlac excelu na 2 pc

Michalko • 24.6. 7:04

rozlisna tlac excelu na 2 pc

Stalker • 23.6. 20:41

rozlisna tlac excelu na 2 pc

Michalko • 23.6. 17:55

Načíst a označit shodu

Jess • 21.6. 17:38

Tlac s farebneho

ivana1 • 19.6. 22:16

GRAF teploty

Scraper • 18.6. 15:34

Vyhledat dnešní datum když je číslo jako text

veny • 17.6. 13:56