Problems with VBA code

[KlausW]

Hi
I am using this VBA code to move item from one sheet to another. And it has worked really well, but I've had something done that I can't figure out how to fix. So now I'm getting this error message. See picture 3

Anyone who can help?
Any help will be appreciated.

Best Regards
Klaus W

File for help

Option Explicit
Dim wb As Workbook
Dim WsPris As Worksheet, WsBestil As Worksheet
Dim rPris As Range, rBestil As Range

Private Sub SetVar()
Set wb = ActiveWorkbook
Set WsPris = wb.Sheets("Prisliste")
Set WsBestil = wb.Sheets("Bestilling")
Set rPris = WsPris.Range("A8", WsPris.Range("A5000").End(xlUp))
Set rBestil = WsBestil.Range("A5", WsBestil.Range("A5000").End(xlUp).Offset(6, 0))
End Sub

Sub Prisliste_Overfør_Varer_Klik()
    Application.ScreenUpdating = False
    SetVar
    Dim col As New Collection
    Dim Varelinje As New ClVarelinjer
    Dim vElement
    Dim Cell As Range, iCell As Range
    For Each Cell In rPris
        If Cell.Offset(0, 2) <> "" Then
            With Varelinje
                 .Vare_nr = Cell.Value
                 .Navn = Cell.Offset(0, 1).Value
                 .Antal = Cell.Offset(0, 2).Value
                 .Enhed = Cell.Offset(0, 4).Value
                 .Bemærkning = Cell.Offset(0, 5).Value
                 .Bemærkning1 = Cell.Offset(0, 6).Value
                 .Bemærkning2 = Cell.Offset(0, 7).Value
            End With
        Else
            GoTo Videre
        End If
        For Each iCell In rBestil
            With Varelinje
                If iCell.Value = .Vare_nr Then
                    iCell.Value = .Vare_nr
                    iCell.Offset(0, 1).Value = .Navn
                    iCell.Offset(0, 2).Value = .Antal
                    iCell.Offset(0, 3).Value = .Enhed
                    iCell.Offset(0, 4).Value = .Bemærkning
                    
                    iCell.Offset(0, 5).Value = .Bemærkning1
                    iCell.Offset(0, 6).Value = .Bemærkning2
                    GoTo Videre
                ElseIf iCell.Value = "" Then
                    iCell.Value = .Vare_nr
                    iCell.Offset(0, 1).Value = .Navn
                    iCell.Offset(0, 2).Value = .Antal
                    iCell.Offset(0, 3).Value = .Enhed
                   iCell.Offset(0, 4).Value = .Bemærkning
                   
                    iCell.Offset(0, 5).Value = .Bemærkning1
                    iCell.Offset(0, 6).Value = .Bemærkning2
                    GoTo Videre
                End If
            End With
        Next
                
      
Videre:
        Set Varelinje = New ClVarelinjer
    Next Cell
    Cbox
    'renser antal og bemærkning i prislisten
    ClearOmråde WsPris.Range("C9", WsPris.Range("C6000").End(xlUp))
    'ClearOmråde WsPris.Range("K9", WsPris.Range("K6000").End(xlUp))
    '
    Slet_række
    ' sorterer
    Sorter WsBestil.Range("A8", WsBestil.Range("g6000").End(xlUp)), WsBestil.Range("B9", WsBestil.Range("B6000").End(xlUp))
    WsPris.Range("a1").Value = Now()
    ' sætter kanter
    IngenKanter WsBestil, WsBestil.Range("a8", WsBestil.Range("g6000"))
    Kanter WsBestil, WsBestil.Range("a8", WsBestil.Range("g6000").End(xlUp))
    WsPris.Activate
    Application.ScreenUpdating = True
 
 End Sub
Private Sub Cbox()

Dim fCbox As ComboBox
Set fCbox = ComboBox1
fCbox.Value = ""

Me.ComboBox1.Activate


End Sub

Private Sub Slet_række()
    Dim ColC As Range
    Dim rRække As Range
    Dim Cell As Range
Forfra:
    With WsBestil
        Set ColC = .Range("C9", .Range("C6000").End(xlUp))
        For Each Cell In ColC
            If Cell.Value = 0 And Cell.Value <> "" Then
                .Activate
                Set rRække = .Range("A" & Cell.row, "H" & Cell.row)
                ClearOmråde .Range(rRække.Address)
                GoTo Forfra
            End If
        Next Cell
    End With
End Sub
Private Sub ComboBox1_KeyDown(ByVal Keycode As MSForms.ReturnInteger, ByVal shift As Integer)
    
    If Keycode = 9 Then
        Range("c9").Activate
    End If
    
End Sub
Private Sub worksheet_change(ByVal Target As Range)
 
If Not Intersect(Target, Sheets("Prisliste").Range("c9:c4000")) Is Nothing Then

Call Prisliste_Overfør_Varer_Klik
 
End If

End Sub

 

[davesexcel]

I believe it's the clearing of the cell at the end of the code, possibly an infinit loop?

Turn off events, before calling the macro seems to work. Then turn on events after the macro has finished.

Private Sub worksheet_change(ByVal target As Range)
    If Not Intersect(target, Sheets("Prisliste").Range("c9:c4000")) Is Nothing Then
        Application.EnableEvents = False
        Call Prisliste_Overfør_Varer_Klik
        Application.EnableEvents = True
    End If
End Sub

 

[KlausW]

I believe it's the clearing of the cell at the end of the code, possibly an infinit loop?

Turn off events, before calling the macro seems to work. Then turn on events after the macro has finished.

Private Sub worksheet_change(ByVal target As Range)
    If Not Intersect(target, Sheets("Prisliste").Range("c9:c4000")) Is Nothing Then
        Application.EnableEvents = False
        Call Prisliste_Overfør_Varer_Klik
        Application.EnableEvents = True
    End If
End Sub

Thanks allot have a nice day KW