VBA code does not run properly with formulas

KlausW

Active Member
Joined
Sep 9, 2020
Messages
380
Office Version
  1. 2016
Platform
  1. Windows
Hi

I am using this The VBA code to move the item from the Prisliste sheet to the Bestilling sheet.
The items in the Prisliste sheet start at A9 and In Row 8 is a header.
The items must be transferred to the Bestilling sheet from A9 onwards, here is also a header I Row 8

It works as it shroud, but when I put in formula the Bestilling sheets to search for information in another sheets, the item is moved to defined place in the Bestilling sheet. If I don’t put in formula in the Bestilling sheet it works as it should

Any help will be appreciated
Best regards
Klaus W

Link to files

PIC 1: Is where I order item in sheet Prisliste

PIC 2: Move item without formula

PIC 3: Move item with formula

VBA Code:
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("A8", WsBestil.Range("A5000").End(xlUp).Offset(5, 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
                 '.Pris = Cell.Offset(0, 5).Value
                 '.Bemærkning = Cell.Offset(0, 4).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, 4).Value = .Enhed
                    'iCell.Offset(0, 5).Value = .Pris
                    'iCell.Offset(0, 5).NumberFormat = "$ #,##0.00"
                   ' iCell.Offset(0, 6).Value = .Bemærkning
                    'iCell.Offset(0, 7).FormulaR1C1 = "=IFERROR(RC[-5]*RC[-2],"""")"
                    'iCell.Offset(0, 7).NumberFormat = "$ #,##0.00"
                    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, 4).Value = .Enhed
                   ' iCell.Offset(0, 5).Value = .Pris
                   ' iCell.Offset(0, 5).NumberFormat = "$ #,##0.00"
                   ' iCell.Offset(0, 6).Value = .Bemærkning
                    'iCell.Offset(0, 7).FormulaR1C1 = "=IFERROR(RC[-5]*RC[-2],"""")"
                   ' iCell.Offset(0, 7).NumberFormat = "$ #,##0.00"
                    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 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
 

Attachments

  • Pic1.png
    Pic1.png
    75.5 KB · Views: 17
  • Pic2.png
    Pic2.png
    46.7 KB · Views: 15
  • Pic3.png
    Pic3.png
    37.8 KB · Views: 15

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce

Forum statistics

Threads
1,215,093
Messages
6,123,067
Members
449,090
Latest member
fragment

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top