Please can you advise how I tweak the below code to only move row data for columns A:H?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 11 Then
If Target = "Complete" Then
nxtRw = Sheets("Completed").Range("A" & Rows.Count).End(xlUp).Row + 1
Target.EntireRow.Copy Sheets("Completed").Range("A" & nxtRw)
Application.EnableEvents = False
Target.EntireRow.Delete shift:=xlUp
Application.EnableEvents = True
ElseIf Target.Column = 11 Then
If Target = "Cancelled" Then
nxtRw = Sheets("Completed").Range("A" & Rows.Count).End(xlUp).Row + 1
Target.EntireRow.Copy Sheets("Completed").Range("A" & nxtRw)
Application.EnableEvents = False
Target.EntireRow.Delete shift:=xlUp
Application.EnableEvents = True
End If
End If
End If
End Sub
At the moment it moves the whole row over. in the sheet it moves to I have additional validation lists in rows I,J,K which it removes when it copies over.
Any help is much appreciated
thanks
Matt
Use the Resize property. You can also shorten your If slightly.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 11 Then
If Target = "Complete" Then
nxtRw = Sheets("Completed").Range("A" & Rows.Count).End(xlUp).Row + 1
Cells(Target.Row, 1).Resize(, 8).Copy Sheets("Completed").Range("A" & nxtRw)
Application.EnableEvents = False
Target.EntireRow.Delete shift:=xlUp
Application.EnableEvents = True
ElseIf Target = "Cancelled" Then
nxtRw = Sheets("Completed").Range("A" & Rows.Count).End(xlUp).Row + 1
Cells(Target.Row, 1).Resize(, 8).Copy Sheets("Completed").Range("A" & nxtRw)
Application.EnableEvents = False
Target.EntireRow.Delete shift:=xlUp
Application.EnableEvents = True
End If
End If
End Sub
Related
Amateur here - sorry if this is simple and I'm not getting it.
So in my workbook I have a timer that updates every 3 mins In A2. In B2, C2, D2, etc. I have fluctuating values from plugins, that have a very fast refresh rate.
I need a macro that will "log" the values in B2, C2 etc. as a new row, every time the value in A2 changes(with the time from the timer there also). Here is what I have so far(excluding timer macro, it works great):
Private Sub Worksheet_Calculate()
Worksheet_Change Range("A2")
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A2")) Is Nothing Then
Application.EnableEvents = False
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("A2").Value
Application.EnableEvents = True
Application.EnableEvents = False
Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("B2").Value
Application.EnableEvents = True
Application.EnableEvents = False
Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("C2").Value
Application.EnableEvents = True
Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("D2").Value
Application.EnableEvents = True
Range("E" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("E2").Value
Application.EnableEvents = True
Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("F2").Value
Application.EnableEvents = True
Range("G" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("G2").Value
Application.EnableEvents = True
Range("H" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("H2").Value
Application.EnableEvents = True
End If
End Sub
The problem with this code is that when I use the plug in to put in the values for B2, C2 etc, everything goes wild and it starts creating new rows(if you want to try this for yourself, put =RANDBETWEEN(40,80) as one of the values - it perfectly emulates the problem I face).
Back to my question, how do I make the macro only create a new row when there is a change in A2?
Any help is welcome, thanks you for your time!
I've tested this and it does what you expect it to (replace your code with the following and remove the worksheet_calculate) Also you should probably change Sheet1 to whatever your Sheet is or even to ActiveSheet:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = Sheet1.Range("A2").Address Then 'check to see if changes happend on A2
Application.EnableEvents = False
Sheet1.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = Sheet1.Range("A2").Value 'copy the row from Row 2 to next empty row
Sheet1.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = Sheet1.Range("B2").Value
Sheet1.Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = Sheet1.Range("C2").Value
Sheet1.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Value = Sheet1.Range("D2").Value
Sheet1.Range("E" & Rows.Count).End(xlUp).Offset(1, 0).Value = Sheet1.Range("E2").Value
Sheet1.Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Value = Sheet1.Range("F2").Value
Sheet1.Range("G" & Rows.Count).End(xlUp).Offset(1, 0).Value = Sheet1.Range("G2").Value
Sheet1.Range("H" & Rows.Count).End(xlUp).Offset(1, 0).Value = Sheet1.Range("H2").Value
Application.EnableEvents = True
End If
End Sub
I have two working Worksheet_Change code and I would like to use both of them on the same sheet. When I use them individually both of them work but when I use them together they do not. I tried to paste in two different codes but I got an ambiguous name detected error. I also tried to use elseif, next but none of them worked.
The two codes:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("O:O"), Target) Is Nothing Then
Cells(Target.Row, 17).Value = Date
End If
End Sub
and
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Column = 15 Then
Range("P" & Target.Row).Value = Target.Value + Range("P" & Target.Row).Value
Application.EnableEvents = False
Target.Value = ""
Application.EnableEvents = True
End If
End Sub
Thank you for your help
you can just put both workshett Change events in the same sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("O:O"), Target) Is Nothing Then
Cells(Target.Row, 17).Value = Date
End If
If Target.Column = 15 Then
Range("P" & Target.Row).Value = Target.Value + Range("P" & Target.Row).Value
Application.EnableEvents = False
Target.Value = ""
Application.EnableEvents = True
End If
End Sub
Try it like this...
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Not Intersect(Range("O:O"), Target) Is Nothing Then
Application.EnableEvents = False
Cells(Target.Row, 17).Value = Date
Range("P" & Target.Row).Value = Target.Value + Range("P" & Target.Row).Value
Target.Value = ""
Application.EnableEvents = True
End If
End Sub
Currently I have this code. In Column A, I have a current a "YES" or "No" Selection.
Private Sub worksheet_change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A")) Is Nothing Then
ActiveSheet.Unprotect
If Target = "YES" Then
'Column B to S
For i = 1 To 18
With Target.Offset(0, i)
.Locked = False
.FormatConditions.Add Type:=xlExpression, Formula1:="=ISBLANK(" & Target.Offset(0, i).Address & ")"
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
.Interior.ColorIndex = 4
End With
End With
Next i
ElseIf Target = "NO" Then
For i = 1 To 73
With Target.Offset(0, i)
.Value = ""
.Locked = True
.FormatConditions.Delete
End With
Next i
End If
ActiveSheet.Protect
End If
End Sub
Now when the user click the cell in Column T (19), I want to display a warning message to the user that this is not applicable for "Yes" selection.
This seems like it should do the task you are asking.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A")) Is Nothing Then
On Error GoTo bm_SafeExit
Application.EnableEvents = False
Me.Unprotect
Dim trgt As Range
For Each trgt In Intersect(Target, Range("A:A"))
If LCase(trgt.Value2) = "yes" Then
With trgt.Offset(0, 1).Resize(1, 18)
.Locked = False
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=ISBLANK(B" & trgt.Row & ")")
.Interior.ColorIndex = 4
End With
End With
Else
With trgt.Offset(0, 1).Resize(1, 73)
.Value = vbNullString
.Locked = True
.FormatConditions.Delete
End With
End If
Next trgt
End If
bm_SafeExit:
Application.EnableEvents = True
Me.Protect Userinterfaceonly:=True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("T:XFD")) Is Nothing Then
On Error GoTo bm_SafeExit
Application.EnableEvents = False
Dim trgt As Range
For Each trgt In Intersect(Target, Range("T:XFD"))
If LCase(Me.Cells(trgt.Row, "A").Value2) = "yes" Then
MsgBox "Don't try to put Yes here", vbCritical + vbOKOnly, "Bad Choice"
Me.Cells(trgt.Row, "A").Select
End If
Next trgt
End If
bm_SafeExit:
Application.EnableEvents = True
End Sub
Set watches and breakpoints and use [F8] and [Ctrl]+[F8} to walk through the code.
I have the setup as shown in the image above.
Logic of the macro is if I enter a number 1 in cell B5 or in empty cell in Range("B2:B26") then the output would be in this format:
B2 3
B3 4
B4 2
B5 1
Now it gives me that output but there are certain drawbacks e.g.
if I provide input 8 to the same cell then it will still increment the ranks. I incorporated a match check to see if that value is there or not but it doesn't seem to work Any help would be appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim KeyCells As Range
Dim i As Long, Cel As Range, sht1 As Worksheet, j As Long, found As Boolean
Set sht1 = Sheet1
Set KeyCells = sht1.Range("B2:C26")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
If Target.Column = 2 Then
For i = 2 To 26
If sht1.Range("B" & i) <> Empty And sht1.Range("B" & i).Value >= Target.Value And i <> Target.Row Then
sht1.Range("B" & i).Value = sht1.Range("B" & i).Value + 1
Else: End If
Next i
Else: End If
If Target.Column = 3 Then
For i = 2 To 26
If sht1.Range("C" & i) <> Empty And sht1.Range("C" & i).Value >= Target.Value And i <> Target.Row Then
sht1.Range("C" & i).Value = sht1.Range("C" & i).Value + 1
Else: End If
Next i
Else: End If
Else: End If
Call CreateDataLabels
Target.Select
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Is this what you are trying? I have not extensively tested it
Option Explicit
Dim rng As Range
Private Sub Worksheet_Change(ByVal Target As Range)
Dim oldVal As Long, i as Long
On Error GoTo Whoa
Application.EnableEvents = False
Set rng = Range("B2:B26")
If Not Intersect(Target, rng) Is Nothing Then
oldVal = Target.Value
If NumExists(oldVal, Target.Row) = True Then
For i = 2 To 26
If i <> Target.Row And Range("B" & i).Value >= oldVal Then _
Range("B" & i).Value = Range("B" & i) + 1
Next i
End If
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Function NumExists(n As Long, r As Long) As Boolean
Dim i As Long
For i = 2 To 26
If Range("B" & i) = n And r <> i Then
NumExists = True
Exit Function
End If
Next i
End Function
edited to remove "helper" values
edited to add functionality for column C as well
Being Siddharth Rout's answer the solution, and having the OP's not asked for anything more, I'd propose the following as an alternative option to possibly be discussed if worth considering
Option Explicit
Private Sub Worksheet_Change(ByVal target As Range)
Dim oldVal As Long
Dim wrkRng As Range
Application.EnableEvents = False
On Error GoTo EndThis
If Continue(target, Range("B2:C26").Cells, oldVal, wrkRng) Then '<== here you set "B2:C26" as the "sensitive" range
With wrkRng
.Offset(, 2).Value = .Value
.FormulaR1C1 = "=IF(RC[2]<>"""",RC[2]+IF(and(RC[2]>=" & oldVal & ",ROW(RC)<>" & target.Row & "),1,0),"""")"
.Value = .Value
.Offset(, 2).ClearContents
End With
End If
EndThis:
If Err Then MsgBox Err.Description
Application.EnableEvents = True
Exit Sub
End Sub
Function Continue(target As Range, rng As Range, oldVal As Long, wrkRng As Range) As Boolean
If target.Cells.Count = 1 Then
If Not IsEmpty(target) Then ' if cell has not been cancelled
Set wrkRng = Intersect(target.EntireColumn, rng)
If Not wrkRng Is Nothing Then
oldVal = target.Value
Continue = Application.WorksheetFunction.CountIf(wrkRng, oldVal) > 1
End If
End If
End If
End Function
as compared to Siddharth Rout's solution, it enhances the following:
more (complete?) testing as if to go on with rng processing
in previous solution
if you cancelled a cell in rng it'd add 1's in all rng cells
if you pasted values in more then one rng cells it'd throw an error
no use of cells iteration, both for oldVal counting purposes and for ranking updating
I am creating an Excel spreadsheet. I have 2 separate functions that I need to combine but I am not sure how to smash them together. I know I can only have 1 change event. The first function will unprotect the sheet (column c is locked), auto populate column C when data is entered in to column A or erase C when A is erased and re-protect when complete. The second will return the cell focus to the next row, column A, when data is entered into A and B. Separately they work as needed.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Unprotect Password:="my password"
If Target.Column = 1 Then
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Target.Offset(0, 1 - Target.Column).Value = "" Then
Target.Offset(0, 3 - Target.Column).Clear
Exit Sub
End If
Application.EnableEvents = False
For Each r In Inte
r.Offset(0, 2).Value = Date & " " & Time
r.Offset(0, 2).NumberFormat = "m/d/yyyy h:mm am/pm"
Next r
Application.EnableEvents = True
End If
Protect Password:="my password"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
Application.EnableEvents = False
If Not Target.Cells.CountLarge > 1 Then
If Not Intersect(Target, Columns(1)) Is Nothing Then
Target.Offset(, 1).Select
ElseIf Not Intersect(Target, Columns(2)) Is Nothing Then
Target.Offset(1, -1).Select
End If
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
How about this, seems to do what you want, as I understand the question.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngIntersect As Range
Dim rngCell As Range
On Error GoTo TidyUp
Application.EnableEvents = False
If Target.Column = 1 Then
Set rngIntersect = Intersect(Range("A:A"), Target)
For Each rngCell In rngIntersect
If rngCell.Value = "" Then
rngCell.Offset(0, 2).Value = ""
Else
rngCell.Offset(0, 2).Value = Date & " " & Time
rngCell.Offset(0, 2).NumberFormat = "m/d/yyyy h:mm am/pm"
End If
Next rngCell
End If
If Target.Column < 3 And Target.Value <> "" Then ' lose the 'And Target.Value <> ""' as desired
Cells(Target.Row + Target.Rows.Count, 1).Select
End If
TidyUp:
Set rngIntersect = Nothing
Set rngCell = Nothing
Application.EnableEvents = True
End Sub
I'd also suggest using UserInterfaceOnly in your worksheet.Protect, then you don't have to unprotect the sheet for VBA to act on the sheet.
Implement it in two Sub-Procedures on a modul, then just call both of them in the Event-Procedure.