VBA overføre markeret celle (række)
Hejsa,Har nedenstående VBA der kigger efter om der står JA eller NEJ i kolonne A.
Men kunne godt tænke mig at den kunne overføre den række som jeg har markeret en celle i.
Den skal kigge efter hvilken række jeg har markeret en celle i og overføre den, når jeg klikker på knappen der kører overfør.
Men den skal ikke overføre den markerede linje, hvis der står JA i en celle i kolonne A.
Håber det gav mening.
Dim ws1 As Worksheet, ws2 As Worksheet
Dim LR1 As Long, LR2 As Long, LR3 As Long, LR4 As Long, i As Long
Set ws1 = Sheets("Kalk")
Set ws2 = Sheets("Standardpriser")
LR3 = ws2.Range("N" & Rows.Count).End(xlUp).Row
LR4 = WorksheetFunction.Sum(Range("N18:N" & LR3))
If LR4 < 1 Then
MsgBox "Du skal vælge en linje at overføre"
Sheets("Standardpriser").Select
Exit Sub
End If
Sheets("Kalk").Select ' vælger celle på kalk ark
Range("D" & (ActiveCell.Row)).Select
LR2 = ActiveCell.Row
LR1 = ws2.Range("C" & Rows.Count).End(xlUp).Row
If LR2 < 20 Then 'Sikrer at der ikke bliver overført data til en ulovlig række på kalk ark
MsgBox "Fejl: Du prøver at indsætte værdier i en ulovlig række. Marker en lovlig række hvor du ønsker at indsætte standardprisen"
Sheets("Kalk").Select
Exit Sub
End If
ws1.Unprotect
ws2.Unprotect
Application.ScreenUpdating = False
For i = 20 To LR1
If ws2.Range("A" & i).Value = "Ja" Then
ws1.Cells((ActiveCell.Row), "D").Value = ws2.Cells(i, "C").Value
ws1.Cells((ActiveCell.Row), "E").Value = ws2.Cells(i, "D").Value
ws1.Cells((ActiveCell.Row), "F").Value = ws2.Cells(i, "E").Value * ws2.Cells(i, "B")
ws1.Cells((ActiveCell.Row), "I").Value = ws2.Cells(i, "F").Value * ws2.Cells(i, "B")
ws1.Cells((ActiveCell.Row), "J").Value = ws2.Cells(i, "G").Value * ws2.Cells(i, "B")
ws1.Cells((ActiveCell.Row), "K").Value = ws2.Cells(i, "H").Value * ws2.Cells(i, "B")
ws1.Cells((ActiveCell.Row), "L").Value = ws2.Cells(i, "I").Value * ws2.Cells(i, "B")
ws1.Cells((ActiveCell.Row), "M").Value = ws2.Cells(i, "L").Value
If ws2.Range("B" & i).Value > 1 Then ws1.Cells((ActiveCell.Row), "M").Value = "NEJ" ' Ændrer enhedspris til NEJ, hvis Celle B er større end 1
ws2.Cells(i, "B").Value = 1
Call Makro_indsæt_række
ActiveCell.Offset(1).Select
End If
Next i
' GENLÅSNING AF ARK
Application.ScreenUpdating = True
Worksheets("Standardpriser").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingCells:=True
EnableSelection = xlNoRestrictions
Worksheets("Kalk").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingCells:=True
End Sub