Regne arket låser

Prøv at vis hele koden!

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False

    Dim lngLinie As Long
    Dim strConveyorType As String
    Dim lngPosNr As Long
    Dim lngRowPos As Long
    Dim lngAntal As Long
    Dim astrOutput(1000, 1) As String
   
    'Er vi i den rigtige række ?
    If (Target.Column <> 11 And Target.Column <> 12) Then Exit Sub
      If Target.Column = 12 Then
        strConveyorType = Target.Offset(0, -1)
        test1 = Target
      Else
        strConveyorType = Target
      End If
    'Find grundværier
     
     
      lngLinie = Target.Row
      lngPosNr = Cells(lngLinie, 1)
      lngAntal = Cells(lngLinie, 2)
      lngRowPos = 0
     
    Do
        lngRowPos = lngRowPos + 1
    Loop Until strConveyorType = Worksheets("Standart").Range("A" & CStr(lngRowPos)).Value
 
    Do
      t = t + 1
     
      astrOutput(t, 0) = Worksheets("Standart").Range("B" & CStr(lngRowPos)).Value
      astrOutput(t, 1) = Worksheets("Standart").Range("C" & CStr(lngRowPos)).Value
       
      lngRowPos = lngRowPos + 1
       
      Tekst = Worksheets("Standart").Range("A" & CStr(lngRowPos)).Value
   
    Loop Until strConveyorType <> Tekst And Tekst <> "" Or astrOutput(t, 0) = ""
      tekst1 = Worksheets("Pos.nr.").Range("A" & CStr(t)).Value
      t = 1
    'Kik efter om positionsnr. er der i forvejen
    Do
      t = t + 1
   
    Loop Until Worksheets("Pos.nr.").Range("A" & CStr(t)).Value = Cells(lngLinie, 1) Or Worksheets("Pos.nr.").Range("A" & CStr(t)).Value = ""
    'Hvis positionsnr. er der i forvejen slettet det
    If Worksheets("Pos.nr.").Range("A" & CStr(t)).Value = Cells(lngLinie, 1) Then
   

      Do
          Worksheets("Pos.nr.").Range("A" & CStr(t)).Delete
          Worksheets("Pos.nr.").Range("B" & CStr(t)).Delete
          Worksheets("Pos.nr.").Range("C" & CStr(t)).Delete
          Worksheets("Pos.nr.").Range("D" & CStr(t)).Delete
          Worksheets("Pos.nr.").Range("E" & CStr(t)).Delete
          Worksheets("Pos.nr.").Range("F" & CStr(t)).Delete
          Worksheets("Pos.nr.").Range("G" & CStr(t)).Delete
   
        Loop Until Worksheets("Pos.nr.").Range("A" & CStr(t)).Value <> Cells(lngLinie, 1) Or Worksheets("Pos.nr.").Range("A" & CStr(t)).Value = ""
      'else
    End If
    'Find første tomme plads i PosNr kolonne
    'Loop
   
      t = t - 1
     
    Do
      t = t + 1
    Loop Until Worksheets("Pos.nr.").Range("A" & CStr(t)).Value = "" 'Or tekst1 = Cells(lngLinie, 1)

    'Indsæt Array astrOutput(T, 1) i PosNr kolonne
   
    Do
      Y = Y + 1
    'Pos.nr.
      Worksheets("Pos.nr.").Range("A" & CStr(t)).Value = Cells(lngLinie, 1)
    'Antal
      Worksheets("Pos.nr.").Range("B" & CStr(t)).Value = Cells(lngLinie, 2)
    'Varenr.
      Worksheets("Pos.nr.").Range("C" & CStr(t)).Value = astrOutput(Y, 0)
    'Stk
      Worksheets("Pos.nr.").Range("E" & CStr(t)).Value = astrOutput(Y, 1)
   
      t = t + 1
    Loop Until astrOutput(Y, 0) = ""
   
      t = t - 1
      Worksheets("Pos.nr.").Range("A" & CStr(t)).Value = ""
      Worksheets("Pos.nr.").Range("B" & CStr(t)).Value = ""
      Worksheets("Pos.nr.").Select
      Worksheets("Pos.nr.").Range("A2:G" & ActiveCell.SpecialCells(xlLastCell).Row).Select
     
    If Worksheets("List").Range("L" & lngLinie).Value <> "Eksta udstyr" Then
      Do
        lngRowPos1 = lngRowPos1 + 1
      Loop Until Worksheets("List").Range("L" & lngLinie).Value = Worksheets("hjælp").Range("B" & CStr(lngRowPos1)).Value
 
  'If Worksheets("List").Range("L" & lngLinie).Value = "Scanner" Then
       
      Worksheets("Pos.nr.").Range("C" & CStr(t)).Value = Worksheets("hjælp").Range("C" & CStr(lngRowPos1)).Value
    'Pos.nr.
      Worksheets("Pos.nr.").Range("A" & CStr(t)).Value = Cells(lngLinie, 1)
    'Antal
      Worksheets("Pos.nr.").Range("B" & CStr(t)).Value = Cells(lngLinie, 2)
    End If
   
   
 
      Selection.Sort Key1:=Worksheets("Pos.nr.").Range("A1"), Order1:=xlAscending, Header:=xlNo, _
      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
   
   
      Worksheets("List").Activate
      Application.ScreenUpdating = True

End Sub

kopierer du manuelt eller med kode

hvis du bruger kode skal du slå automatiske makroer fra sådan


Application.EnableEvents = False
' din copykode
Application.EnableEvents = True

Jeg kopierer manuel

Ændring til toppen af makroen

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub ' hopper ud hvis flere end 1 celle ændres
    If (Target.Column <> 11 And Target.Column <> 12) Then Exit Sub
    Application.ScreenUpdating = False
    Dim lngLinie As Long
    Dim strConveyorType As String
    Dim lngPosNr As Long
    Dim lngRowPos As Long
    Dim lngAntal As Long
    Dim astrOutput(1000, 1) As String
    If Target.Cells.Count > 1 Then Exit Sub
    'Er vi i den rigtige række ?
    If Target.Column = 12 Then
        strConveyorType = Target.Offset(0, -1)
        test1 = Target
    Else
        strConveyorType = Target
    End If
    'Find grundværier

der var lige en linie for meget med.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub ' hopper ud hvis flere end 1 celle ændres
    If (Target.Column <> 11 And Target.Column <> 12) Then Exit Sub
    Application.ScreenUpdating = False
    Dim lngLinie As Long
    Dim strConveyorType As String
    Dim lngPosNr As Long
    Dim lngRowPos As Long
    Dim lngAntal As Long
    Dim astrOutput(1000, 1) As String
    'Er vi i den rigtige række ?
    If Target.Column = 12 Then
        strConveyorType = Target.Offset(0, -1)
        test1 = Target
    Else
        strConveyorType = Target
    End If
    'Find grundværier

Det er bare noget der virker tusind tak.
sender du et svar.

et svar ;-))