I have a worksheet comprising of two columns (A and B) ... the first of which is just a name, the second is a number.
If I make an edit to a number in column B, I want Excel to automatically copy that entire row to a second worksheet in order to create a list of edits that I have made.
The second worksheet would then be a continually updated list of changes that I have made to the first sheet, with the latest change (a copy of the two updated columns) added to the next unused row.
I hope that a bit of VBA trickery might be able to make this happen, but require some help to make it happen.
Try this in the sheet where you have data (under the Excel Objects), e.g Sheet1
Option Explicit
Dim PrevVal As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 Then
Application.ScreenUpdating = False
Dim rng As Range
Dim copyVal As String
Set rng = Nothing
Set rng = Range("A" & Target.Row & ":B" & Target.Row)
'copy the values
With Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp)
.Offset(1, 0).Resize(1, rng.Cells.Count).Value = rng.Value
With Worksheets("Sheet1")
Range("A" & Target.Row).Copy
copyVal = CStr(PrevVal)
End With
.Offset(1, 0).PasteSpecial xlPasteFormats
.Offset(1, 1) = copyVal
Application.CutCopyMode = False
End With
End If
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Rows.Count > 1 Then Exit Sub
If Target.Columns.Count > 1 Then Exit Sub
PrevVal = Target.Value
End Sub
Here is some additional code to check the row number, as per the above answer and comments.
Dim row_num As Long
row_num = Cells(Rows.Count, "B").End(xlUp).Row
If row_num > 1 then row_num = row_num + 1 'Add 1 only when row number doesn't equal to 1, otherwise - 1.
Related
I am aiming to lock entire rows where the word "Done" appears in a specific column. My code below achieves what I seek but it takes 18 seconds to compute (too long). Is there a faster/more efficient coding alternative?
There is an existing question on StackOverflow similar to this (found here) but my data does not exist in defined tables (this won't change), so I don't know how to adapt the suggestion there.
Private Sub Lock_Rows(ByVal Target As Range)
Dim DestSh As Worksheet
Dim lastrow As Long
Dim i As Long ' Integer
Set DestSh = Worksheets(8) 'Data tab for Item 1
With DestSh
'finds the last row with data on B column, B column has dates
lastrow = .Range("B" & .Rows.Count).End(xlUp).Row
'parse all rows
For i = 26 To lastrow 'rows of data begin at row 26
'if your conditions are met
If .Cells(i, "Z").Value = "Done" Then
.Cells(i, "Z").EntireRow.Cells.Locked = True 'lock the row
Else
.Cells(i, "Z").EntireRow.Cells.Locked = False 'leave rows unlocked
End If
Next i
.Protect UserInterfaceOnly:=True
End With
Set DestSh = Nothing
End Sub
The Lock / Unlock operations om individual rows are quite slow. Better to build a range reference to Lock / Unlock and do that operation in on go at the end.
Something like
Private Sub Lock_Rows(ByVal Target As Range)
Dim DestSh As Worksheet
Dim lastrow As Long
Dim i As Long ' Integer
Dim rLock As Range, rUnlock As Range
Set DestSh = Worksheets(8) 'Data tab for Item 1
With DestSh
'finds the last row with data on B column, B column has dates
lastrow = .Range("B" & .Rows.Count).End(xlUp).Row
'parse all rows
For i = 26 To lastrow 'rows of data begin at row 26
'if your conditions are met
If .Cells(i, "Z").Value = "Done" Then
If rLock Is Nothing Then
Set rLock = .Cells(i, "Z").EntireRow
Else
Set rLock = Application.Union(rLock, .Cells(i, "Z").EntireRow)
End If
Else
If rUnlock Is Nothing Then
Set rUnlock = .Cells(i, "Z").EntireRow
Else
Set rUnlock = Application.Union(rUnlock, .Cells(i, "Z").EntireRow)
End If
End If
Next i
If Not rLock Is Nothing Then rLock.Locked = True
If Not rUnlock Is Nothing Then rUnlock.Locked = False
.Protect UserInterfaceOnly:=True
End With
Set DestSh = Nothing
End Sub
It will be faster still you could incorporate use of Variant Arrays on the loop
On my hardware it takes about 6 s to process 500,000 rows
Try with this solution which seems to be much faster than original one:
Private Sub Lock_Rows_new(ByVal Target As Range)
Debug.Print "s:" & Timer
Dim DestSh As Worksheet
Dim lastrow As Long
Dim i As Long ' Integer
Set DestSh = Worksheets(8) 'Data tab for Item 1
With DestSh
'range to search
Dim firstRNGRow As Variant '!! important
firstRNGRow = 26
Dim firstRNG As Range
Set firstRNG = .Cells(firstRNGRow, "Z")
Dim lastRNG As Range
Set lastRNG = .Cells(.Range("B" & .Rows.Count).End(xlUp).Row, "Z")
'unlock all
Range(firstRNG, lastRNG).EntireRow.Cells.Locked = False
'search for first done
firstRNGRow = Application.Match("Done", Range(firstRNG, lastRNG), 0)
Do While (Not IsError(firstRNGRow))
Set firstRNG = .Cells(firstRNG.Row + firstRNGRow, "Z")
firstRNG.Offset(-1, 0).EntireRow.Cells.Locked = True 'lock the row
If firstRNG.Row > lastRNG.Row Then Exit Do
firstRNGRow = Application.Match("Done", Range(firstRNG, lastRNG), 0)
Loop
.Protect UserInterfaceOnly:=True
End With
Set DestSh = Nothing
Debug.Print "e:" & Timer
End Sub
Edited to add a faster solution combining Sort() and AutoFilter()
AutoFilter() can make things fast:
Private Sub Lock_Rows(ByVal Target As Range)
With Worksheets(8)
If IsEmpty(.Range("Z25")) Then .Range("Z25").Value = "xxx" ' be sure you have a column "header" for data in column Z from row 26 downwards
With .Range("Z25:Z" & .Cells(.Rows.Count, "B").End(xlUp).Row)
.EntireRow.Locked = False ' unlock all cells
.AutoFilter field:=1, Criteria1:="Done"
With Intersect(ActiveSheet.UsedRange, .EntireColumn).Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then .SpecialCells(xlCellTypeVisible).EntireRow.Locked = True ' lock only filtered range rows
End With
End With
If .Range("Z25").Value = "xxx" Then .Range("Z25").ClearContents ' remove any "not original" column header
End With
End Sub
if you know that cell Z25 content is always not empty then you can omit the lines:
If IsEmpty(.Range("Z25")) Then .Range("Z25").Value = "xxx"
If .Range("Z25").Value = "xxx" Then .Range("Z25").ClearContents
and if you Sort things, it's even faster:
Option Explicit
Private Sub Lock_Rows(ByVal Target As Range)
Dim dataRange As Range, sortRange As Range, lockRange As Range
With Worksheets("8") ' reference wanted sheet
Set dataRange = .Range("Z25", .Cells(.Rows.Count, "B").End(xlUp))
Set lockRange = Intersect(.Columns("Z"), dataRange)
Set sortRange = Intersect(dataRange.EntireRow, .UsedRange.Columns(.UsedRange.Columns.Count + 1)) ' reference the range in same rows as referenced one but in first "not used" column
Set dataRange = .Range(dataRange, sortRange)
End With
With sortRange
.Formula = "=ROW()" ' write rows indexes in referenced range. this will be used to sort things back
.Value = .Value ' get rid of formulas
End With
dataRange.Sort key1:=lockRange.Resize(1), order1:=xlAscending, Header:=xlYes ' sort data on columns with possible "Done" values
If IsEmpty(lockRange(1, 1)) Then lockRange(1, 1).Value = "xxx" ' remove any "not original" column header
With dataRange ' reference referenced sheet column B range in
.AutoFilter field:=lockRange.Column - Columns(1).Column, Criteria1:="Done"
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then .SpecialCells(xlCellTypeVisible).EntireRow.Locked = True ' lock only filtered range rows
End With
.Parent.AutoFilterMode = False
.Sort key1:=sortRange.Resize(1), order1:=xlAscending, Header:=xlYes ' sort things back
sortRange.ClearContents ' delete rows index, not needed anymore
End With
If lockRange(1, 1).Value = "xxx" Then lockRange(1, 1).ClearContents ' remove any "not original" column header
End Sub
again, if you know that cell Z25 content is always not empty then you can omit the lines:
If IsEmpty(lockRange(1, 1)) Then lockRange(1, 1).Value = "xxx" ' remove any "not original" column header
If lockRange(1, 1).Value = "xxx" Then lockRange(1, 1).ClearContents ' remove any "not original" column header
I have several column with a few hundred rows of data. One of my roles is to look through the data (most commonly in column 2), So what I do is click the little drop down arrow on the column header to open the auto filter list, deselects the first value, then select the next value. Then, likewise, open menu, deselect second value and select third.
There's no fixed number of values either. Different data sheets have varying amounts of data. The data usually goes like 0,10,40,50,60,.... Again it isn't fixed. It is an array however. All the data is in increasing order already.
What I need:
Preferably a button to click (for column 2) that deselects the currently selected value, selects the next value and filters that out
The converse. I.e. Deselects the current value, selects the previous value
Essentially I need a Forward and Back button for my data.
This is what I get when I tried to record my actions.
Sub a()
ActiveSheet.Range("$A$2:$V$609").AutoFilter Field:=2, Criteria1:
="750385/000"
ActiveSheet.Range("$A$2:$V$609").AutoFilter Field:=2, Criteria1:
="750385/010"
ActiveSheet.Range("$A$2:$V$609").AutoFilter Field:=2, Criteria1:
="750385/017"
End Sub
Appreciate any help!!
There is a method to read out the curent filter, from which on you can loop through the column untill you find that value. here you just need to jump to the value in the next row, which now you can put into the filter.
So in conclusion this method would be your "forward"-button
Sub test()
Dim startRow As Integer
startRow = 2
Dim rangeString As String
rangeString = "$A$2:$V$609"
Dim rng As Range
Set rng = Range(rangeString)
Dim currentCrit As String
currentCrit = rng.Parent.AutoFilter.Filters(2).Criteria1
currentCrit = Right(currentCrit, Len(currentCrit) - 1)
Dim i As Integer
For i = startRow To startRow + rng.Rows.Count
If Cells(i, 2).Value = currentCrit Then
i = i + 1
Exit For
End If
Next
If i > rng.Rows.Count + startRow Then
Exit Sub
End If
ActiveSheet.Range(rangeString).AutoFilter Field:=2, Criteria1:=Cells(i, 2).Value
End Sub
Note: This won´t work if there are duplicates in you column B, if this is so replace the part with the For-Loop with the following:
Dim i As Integer
Dim bool As Boolean
bool = False
For i = startRow To startRow + rng.Rows.Count
If Cells(i, 2).Value = currentCrit Then
bool = True
End If
If bool And Cells(i, 2).Value <> currentCrit Then
Exit For
End If
Next
Hope I could help.
I would use Spinbuttons on the sheet and link them to the first cell of the column, it want to filter.
(I called it spbFilterChange and linked it to $B$1)
(picture upload doesnt work here, sorry)
Then you can put the following code in the module of your worksheet:
Private Sub spbFilterChange_SpinDown()
Change_Filter Me.Range(Me.spbFilterChange.LinkedCell), False
End Sub
Private Sub spbFilterChange_SpinUp()
Change_Filter Me.Range(Me.spbFilterChange.LinkedCell), True
End Sub
And the following sub in a standard module:
Option Explicit
Sub Change_Filter(SortField As Range, Up As Boolean)
Dim Filter_Values As Collection
Dim Value_Arr, Val, Sort_Value As String
Application.ScreenUpdating = False
' Find Unique Values in relevant Column -> Collection
Set Filter_Values = New Collection
SortField.Offset(2, 0).Areas(1).AutoFilter SortField.Column
Value_Arr = SortField.Parent.Range(SortField.Offset(3, 0), SortField.Parent.Cells(SortField.Parent.Rows.Count, SortField.Column).End(xlUp)).Value2
On Error Resume Next
For Each Val In Value_Arr
Filter_Values.Add Val, CStr(Val)
Next Val
' Check if Value of LinkedCell is in range
If SortField.Value < 1 Or SortField.Value > Filter_Values.Count Then SortField.Value = 1
' set autofilter
Sort_Value = Filter_Values(SortField.Value)
SortField.Offset(2, 0).AutoFilter SortField.Column, Sort_Value
Application.ScreenUpdating = True
End Sub
This should solve your problem and could be used on different columns and sheets (you have to add another copy of the event-procedures in the worksheet-module).
I would do something like this.
First: Get Help column X where you copy all the Unique data from column B for example.
Option Explicit
Sub CreateUniqueList()
Dim lastrow As Long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
ActiveSheet.Range("B1:B" & lastrow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=ActiveSheet.Range("X1"), _
Unique:=True
ActiveSheet.Range("Y1").Value = "x"
End Sub
Your list could lokk after that like this:
After that, you would need a loop for the buttons:
Something like this.
//The Code is not Testet//
Sub butNextValue()
Dim lastrow As Long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lastrow
If ActiveSheet.Cells(i, 25).Value = "x" Then
If Not ActiveSheet.Cells(i+1, 24)-value = "" Then 'check if next value is there
ActiveSheet.Range("$A$2:$V$609").AutoFilter Field:=2, Criteria1:=ActiveSheet.Cells(i+1, 24)-value
Else
MsgBox "No more Next Values"
End If
Exit For
End If
Next i
End Sub
Sub butPriValue()
Dim lastrow As Long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lastrow
If ActiveSheet.Cells(i, 25).Value = "x" Then
If Not ActiveSheet.Cells(i-1, 24)-value = "Set" OR Not ActiveSheet.Cells(i-1, 24)-value = "" Then 'check if next value is there
ActiveSheet.Range("$A$2:$V$609").AutoFilter Field:=2, Criteria1:=ActiveSheet.Cells(i-1, 24)
Else
MsgBox "No more Pri Values"
End If
Exit For
End If
Next i
End Sub
I need to add a new row whenever a cell values changes in a defined column. I then need it to do the same for another column, then another column after that.
I used the same code three times, with different columns referenced, but I think it is not working due to the new (blank) rows entered from the first run. I've written it as three separate Subs.
Sub LineTestCODE()
Dim lRow As Long
For lRow = Cells(Cells.Rows.Count, "C").End(xlUp).Row To 2 Step -1
If Cells(lRow, "C") <> Cells(lRow - 1, "C") Then Rows(lRow).EntireRow.Insert
Next lRow
End Sub
Sub LineTestENHANCEMENT()
Dim lRow2 As Long
For lRow2 = Cells(Cells.Rows.Count, "D").End(xlUp).Row To 2 Step -1
If Cells(lRow2, "D") <> Cells(lRow2 - 1, "D") Then Rows(lRow2).EntireRow.Insert
Next lRow2
End Sub
Sub LineTestZONE()
Dim lRow3 As Long
For lRow3 = Cells(Cells.Rows.Count, "G").End(xlUp).Row To 2 Step -1
If Cells(lRow3, "G") <> Cells(lRow3 - 1, "G") Then Rows(lRow3).EntireRow.Insert
Next lRow3
End Sub
I'm not exactly sure how you want to add your rows. It looks as if you want to test the changed cell and if it doesn't match the cell above add a row. I guess it's also possible that you want to add one row per unmatching cell pair in your columns. You'll see both in the code below - take your pick.
I put this code in the Sheet_Change event but you could put it in a module and call it from this event if you wished. You'll see I've disabled events, this could be the problem with your code.
This routine doesn't test if someone pasted values (ie Target.Cells.Count > 1). You might want to handle the possibility of Target being multiple cells.
For Each item in Target.Cells
..//..
Next
could work for you.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyColumns As Range
' Define the value columns we're interested in
If MyColumns Is Nothing Then
Set MyColumns = Union(Columns("C"), _
Columns("D"), _
Columns("G"))
End If
' If you just want to add one row for a non-matching change in one of the three columns changes
If Not Intersect(Target, MyColumns) Is Nothing Then
If Target.Row > 1 Then
If Target.Offset(-1).Value <> Target.Value Then
Application.EnableEvents = False
Target.Offset(1).EntireRow.Insert
Application.EnableEvents = True
End If
End If
End If
' If you want to add one row for each non-matching cell value in the three columns
Dim cell As Range
If Not Intersect(Target, MyColumns) Is Nothing Then
If Target.Row > 1 Then
For Each cell In Intersect(MyColumns, Target.EntireRow).Cells
If cell.Offset(-1).Value <> cell.Value Then
Application.EnableEvents = False
cell.Offset(1).EntireRow.Insert
Application.EnableEvents = True
End If
Next
End If
End If
End Sub
Currently, I have columns from A to AB. I want to achieve a result such that if any cell is updated in Columns Y:AB of a row, the cells (Column A and Y:AB of a row) will be copied and pasted into a new sheet called Sheet2 into columns A to E.
My code currently can do the above but when I change all 4 values one by one in Columns Y to AB, 4 rows will be generated reflecting each change that was made. E.g. First row to be copied reflects the change made in Column Y. Second row copied reflects the change made in Column Z. Third row copied reflects the change made in Column AB. And so on.
I just need one row copied onto Sheet 2 that reflects all changes made in Columns Y to AB of a row in Sheet 1. Is there a way to do so?
I am not familiar with VBA and all guidance are much appreciated! Thank you
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns("Y:AB")) Is Nothing Then Exit Sub
Range("Y" & Target.Row, "AB" & Target.Row).Copy Sheets("Sheet2").Range("B" & Rows.count).End(xlUp).Offset(1, 0)
Range("A" & Target.Row).Copy Sheets("Sheet2").Range("A" & Rows.count).End(xlUp).Offset(1, 0)
End Sub
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo halt
Application.EnableEvents = False
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Sheets("Sheet1"): Set sh2 = Sheets("Sheet2")
With sh1
If Intersect(Target, .Range("Y:AB")) Is Nothing Then GoTo forward
Dim trow As Long, drow As Long, rng As Range
trow = Target.Row
Set rng = sh2.Range("A:A").Find(.Range("A" & trow).Value, sh2.Range("A1"))
If rng Is Nothing Then
drow = sh2.Range("A" & .Rows.Count).End(xlUp).Row + 1
sh2.Range("A" & drow) = .Range("A" & trow)
Else
drow = rng.Row
End If
.Range("Y" & trow, "AB" & trow).Copy sh2.Range("B" & drow)
End With
forward:
Application.EnableEvents = True
Exit Sub
halt:
MsgBox Err.Description
Resume forward
End Sub
I assumed Column A contains unique identifier.
So above code does what you describe and what you explained in your comment. HTH.
I am trying to write a macro that will let me copy a range of data from one sheet to another sheet based on a criteria in the column before the column to be copied.
Column B is the criteria column. If there is a 1 in any row in this column then columns C thru AN will be copied from that row where there is a 1 and be pasted into another sheet starting at the top of that sheet.
I have the following code. It locates the first row that satisfies the criteria and copies this row to the second sheet, however the code does not loop thru to find other rows that satisfy the criteria. How can I adjust the code to loop and copy each instance where the criteria is satisfied?
Sub testIt()
Dim i As Integer
Application.ScreenUpdating = False
Sheets("DataDump").Activate
For i = 2 To Range("B2").End(xlDown).Row()
If Range("B" & i).Value = 1 Then
Range("C" & i, "AN" & i).Copy
Sheets("PriceData").Activate
ActiveSheet.Range("B2", "AM2").Select
ActiveSheet.Paste
End If
Next i
Application.ScreenUpdating = True
End Sub
Sub testIt()
Dim i As Long, shtSrc As Worksheet, rngDest As Range
Application.ScreenUpdating = False
Set shtSrc = Sheets("DataDump")
Set rngDest = Sheets("PriceData").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
For i = 2 To shtSrc.Range("B2").End(xlDown).Row
If shtSrc.Range("B" & i).Value = 1 Then
shtSrc.Range("C" & i & ":AN" & i).Copy rngDest
Set rngDest = rngDest.Offset(1, 0)
End If
Next i
Application.ScreenUpdating = True
End Sub