06. september 2006 - 14:30
Der er
7 kommentarer og
1 løsning
Regne arket låser
Når jeg kopier mere en en celle over i mit regne ark låser mit regne ark uden nogle fejlmeldelese det er denne linje i min makro der låser arket "If (Target.Column <> 11 And Target.Column <> 12) Then Exit Sub". Denne linie skal jeg bruge for at makroen skal udføres hvis der bliver lavet ændringer i kolonne 11 og 12.
06. september 2006 - 14:45
#2
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
06. september 2006 - 16:01
#5
Æ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
06. september 2006 - 16:03
#6
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