Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastRow As Long
lastRow = ActiveSheet.Cells(Rows.Count, "E").End(xlUp).Row
ActiveSheet.Unprotect
lastRow.Locked = True
ActiveSheet.Protect
End Sub
*I already run this code. But still not lock the last row.
*When add "MsgBox lastrow" its working and show correct selected row.
*Thank You
Open This For More Info ----> Excel View With Msg Box
In case your cell in Column E is part of a merged cells (in your case Columns E:K are merged), then you set a new Range with the variable MergedCell to the merged area, and then Lock the entire range of merged cells.
Code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastRow As Long, cell As Range, MergedCell As Range
' find last row in Column E
lastRow = ActiveSheet.Cells(Rows.Count, "E").End(xlUp).Row
ActiveSheet.Unprotect
Set cell = Range("E" & lastRow)
' if cell in Column E is part of merged cells
If cell.MergeCells = True Then
Set MergedCell = cell.MergeArea
MergedCell.Locked = True
Else
cell.Locked = True
End If
ActiveSheet.Protect
End Sub
Related
The final goal includes having a table on Sheet1 and when certain criteria is met in the last column of the table, the row is copied to Sheet2 and contents are cleared from that row in Sheet1. What I have now works, and accurately copies and clears the data, but it copies past the last column of the table. Is there a function I can add to limit the number of columns copied? I only want columns A to I copied to the second sheet and then cleared from the first.
This is what I have currently. The reason I want to limit the columns copied and cleared is because I want to have another table next to it.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 9 Then
Application.EnableEvents = False
Dim r As Long
r = Target.Row
Dim Lastrow As Long
Lastrow = Sheets("Tasks").Cells(Rows.Count, "I").End(xlUp).Row + 1
If Target.Value = "Complete" Then
Rows(r).Copy Sheets("Complete Tasks").Cells(Lastrow, 1)
Rows(r).ClearContents
End If
End If
Application.EnableEvents = True
End Sub
It's very simple you have to define a new range without the last column for the row.
Your code may be like this:
(Cell2Copy is the new range to copy )
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell2Copy as Range
Dim r As Long
Dim Lastrow As Long
If Target.Column = 9 Then
Application.EnableEvents = False
r = Target.Row
Lastrow = Sheets("Tasks").Cells(Rows.Count, "I").End(xlUp).Row + 1
If Target.Value = "Complete" Then
set Cell2Copy = Rows(r).Cells(1,Columns.count-1)
Cell2Copy.Copy Sheets("Complete Tasks").Cells(Lastrow, 1)
Rows(r).ClearContents
End If
End If
Application.EnableEvents = True
End Sub
Have a good day.
I'm trying to make a macro that copies the values inside certain cells of sheet1 and pastes then in sheet2.
This is a formula that i wrote inside cell "AI2":
=IFERROR(SUM(1+AH:AH),"0")
and it produces a number that I want to use in the macro as a variable row coordinate.
This is the code i have in my worksheet in order to trigger the macro:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Range("AI2") <> 0 Then
Call macro1
End If
End Sub
And this is the macro:
Sub macro1()
Dim RV As Integer
RV = Sheets("sheet1").Range("AI2").Value
Cells(RR, 33).Select
Range(ActiveCell.Offset(0, -6), ActiveCell.Offset(0, -1)).Select
Selection.Copy
Sheets("sheet2").Select
Range("A1048576").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
If I delete the first 3 lines of code, the macro works, but I have to manually select the cell for the offsets to reference from.
I need to make it so the value of cell "AI2" is used as the first coordinate in this line of code:
Cells(RR, 33).Select
I am very new to any kind of programming, but I want to learn this in order to achieve my goals for this spreadsheet and future ones with similar functions.
I am limiting the scope of your Worksheet_Change to only fire when a change is registered in Column AH since this is the column that will trigger a formula change in Column AI
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 34 Then
If Range("AI2") <> 0 Then
Macro2
End If
End If
End Sub
Sub Macro2()
Dim cs As Worksheet: Set cs = ThisWorkbook.Sheets("Sheet1")
Dim ps As Worksheet: Set ps = ThisWorkbook.Sheets("Sheet2")
Dim xRow As Long, LR As Long
LR = ps.Range("A" & ps.Rows.Count).End(xlUp).Offset(1).Row
xRow = cs.Range("AI2").Value
cs.Range(cs.Cells(xRow, "AB"), cs.Cells(xRow, "AG")).Copy
ps.Range("A" & LR).PasteSpecial xlPasteValues
End Sub
Copy Range to First Empty Cell
Calculate
If you are using a formula in the cell range AI2 you should use the Worksheet Calculate event which will occur everytime the formula is being calculated.
Standard Module
Option Explicit
Public Const strRange As String = "AI2"
Public vntValue As Variant
Sub macro1()
Dim rng As Range ' Target Cell Range
Dim RV As Long ' Row Value
' In Target Worksheet
With ThisWorkbook.Sheets("Sheet2")
' Calculate the first empty (unused) cell in column A (A1 not included).
Set rng = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
End With
' In Source Worksheet
With ThisWorkbook.Worksheets("Sheet1")
' Write the value of Row Cell to Row Value.
RV = .Range(strRange).Value
With .Cells(RV, "AH") ' or 33
' Copy range from "AB" to "AG" in row defined by Row Value in
' Source Worksheet to the range from "A" to "F" in row of Target
' Cell Range in Target Worksheet.
rng.Resize(, 6) = Range(.Offset(0, -6), .Offset(0, -1)).Value
End With
End With
End Sub
Sheet1
Option Explicit
Private Sub Worksheet_Calculate()
If vntValue <> Range(strRange).Value Then
vntValue = Range(strRange).Value
If Range(strRange).Value <> "0" Then macro1
End If
End Sub
ThisWorkbook
Option Explicit
Private Sub Workbook_Open()
vntValue = Worksheets("Sheet1").Range(strRange).Value
End Sub
Change
If you are manually changing the values in the cell range AI2, you have to use the Worksheet Change event.
Standard Module
Option Explicit
Sub macro1()
Dim rng As Range ' Target Cell Range
Dim RV As Long ' Row Value
' In Target Worksheet
With ThisWorkbook.Sheets("Sheet2")
' Calculate the first empty (unused) cell in column A (A1 not included).
Set rng = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
End With
' In Source Worksheet
With ThisWorkbook.Worksheets("Sheet1")
' Write the value of Row Cell to Row Value.
RV = .Range("AI2").Value
' In cell at the intersection of Row Value and column "AH".
With .Cells(RV, "AH") ' or 33
' Copy range from "AB" to "AG" in row defined by Row Value in
' Source Worksheet to the range from "A" to "F" in row of Target
' Cell Range in Target Worksheet.
rng.Resize(, 6) = Range(.Offset(0, -6), .Offset(0, -1)).Value
End With
End With
End Sub
Sheet1
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const cCell As String = "AI2"
If Target = Range(cCell) Then
If Range(cCell).Value <> "0" Then macro1
End If
End Sub
Like in the Calculate version, you might also want to use a public variable (vntValue) to prevent triggering macro1 in case the value in cell range AI2 hasn't actually changed.
I have a table with data from A5:S and would like to sort by a column with "segment" in headline every time a line is inserted.
I have made a numeric column to the left of my string column "segment" which matches my "ranking", the only issue is that it doesn't sort the rows automatically.
I have tried this VBA, but nothing happen:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 Then
Dim lastRow As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A5:S" & lastRow).Sort key1:=Range("A5:A" & lastRow), order1:=xlAscending, Header:=xlGuess
End If
End Sub
If you keep a count of the #of rows in Column A, then when you insert a row, the worksheet_change event can run when the rows increase.
Possible adding enableevents to false would be a good idea so the change_evnt does not kick in when sorting
Dim LstRw As Long
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rws As Long
Rws = Me.Cells(Me.Rows.Count, "A").End(xlUp).Row
If Rws > LstRw Then
Application.EnableEvents = False
MsgBox "Run your code here!"
Application.EnableEvents = True
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
LstRw = Me.Cells(Me.Rows.Count, "A").End(xlUp).Row
End Sub
What about if you change:
if target.column = 2 then
for
if activecell.column = 2 then
I am new to macro Excel functions and I am trying to insert a row when there is a change in the cell value of a particular column. For example,
row_no B
1 p
2 p
3 p
4 q
5 q
6 q
7 q
A row should be inserted at row 3 as the value in column 1 has changed. Do you have any ideas?
Right now, this is my code.
Sub MySub()
Do While B1 <> B2
CurrentSheet.Range("a1:i1").EntireRow.Insert
Loop
End Sub
It is still not working, do all of you have any idea why?
Try this code:
Sub Demo()
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1") 'set you data sheet here
lastRow = Cells(Rows.Count, "A").End(xlUp).Row 'get the last row in column A
For i = lastRow To 2 Step -1 'loop from last row to row 2
If ws.Range("A" & i) <> ws.Range("A" & i - 1) Then 'compare value if not same
ws.Range("A" & i).EntireRow.Insert 'if value are not same insert row
End If
Next i
End Sub
Insert the following into your Sheet1 (Sheet1) VBA module (Or the module that pertains to the worksheet you want this functionality in)
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column = 1 Then Rows(Target.Row + 1).EntireRow.Insert
Application.EnableEvents = True
End Sub
This inserts a row below the changed cell if that cell's column number is column 1 or A
In Sheet1 I have a table with data (no formulas), Range A1:R53. If I update any of the cells, I would like the entire row to be copied and pasted in Sheet2 with the new data.
I don't want the entire table to be copied over, only the row that had a cell changed and the font color to be red. The rows should be pasted in the next available row and not overwrite the previous entries.
Place this event macro in the Sheet1 worksheet code area:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, N As Long
Set rng = Range("A1:R53")
If Intersect(rng, Target) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
Target.Interior.ColorIndex = 27
With Sheets("Sheet2")
If .Cells(1, 1).Value = "" Then
N = 1
Else
N = .Cells(Rows.Count, "A").End(xlUp).Row + 1
End If
Target.EntireRow.Copy .Cells(N, 1)
End With
End Sub
Adjust the color to suit your needs.