If cell is updated, write cell value and timestamp in next blank row - excel

I'm trying to update a column with timestamp and another column with updates (which got from a specific cell).
Desired behaviour:
A2 has xy written to it. That change triggers a macro, which puts timestamp in C column at row 2 and the update in D column row 2.
If new update is made in A2: If C2 is not empty, jump to C3 and put timestamp and put update on D3 and so on.
Unfortunately, it puts the first update timestamp and the update to the columns, but if I update again, it doesn't jump and put update there.
Error message and Excel macro
Excel sheet which I try to update.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xCellColumn As Integer
Dim xCellRow As Integer
Dim xTimeColumn As Integer
Dim xTimeRow As Integer
Dim xUpdateColumn As Integer
Dim xUpdateRow As Integer
Dim xRow, xCol As Integer
xCellColumn = 2
xCellRow = 10
xTimeColumn = 6
xTimeRow = 2
xUpdateColumn = 7
xUpdateRow = 2
i = 2
xCol = Target.Column
xRow = Target.Row
If Target.Text <> "" Then
If xCol = xCellColumn Then
If xRow = xCellRow Then
Do While Range("Munka1").Cells(i, xTimeColumn).Value <> ""
i = i + 1
Loop
Cells(i, xTimeColumn) = Now()
Cells(i, xUpdateColumn) = Target.Value
End If
End If
End If
End Sub

Please try this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xCellColumn As Long
Dim xCellRow As Long
Dim xTimeColumn As Long
Dim xUpdateColumn As Long
Dim SupervisedArea As Range
Dim i As Integer
xCellColumn = 2
xCellRow = 10
xTimeColumn = 6
xUpdateColumn = 7
If Target.Text <> "" Then
' If any changed value in the whole column should generate a new data pair:
'Set SupervisedArea = Intersect(Target, Me.Columns(xCellColumn))
' If only one cell should be supervised:
Set SupervisedArea = Intersect(Target, Me.Cells(xCellRow, xCellColumn))
If Not SupervisedArea Is Nothing Then
i = 2
Do While Me.Cells(i, xTimeColumn).Value <> ""
i = i + 1
Loop
Application.EnableEvents = False
Me.Cells(i, xTimeColumn) = Now()
Me.Cells(i, xUpdateColumn) = Target.Value
Application.EnableEvents = True
End If
End If
End Sub

Related

Excel VBA Code pastes result into wrong range

A script that copies a range into another range. However, when I try to copy the range from Sheet1 to Sheet2 the result won't be pasted into column J, it get pasted with an offset of 8 columns (column R). I cant understand why? Both RowCountSummary and ColumnCountSummary are set to 0, i.e. first index of the range?
Sub InsertForecastData()
Dim ColumnsCount As Integer
Dim ColCounter As Integer
Dim RowsCount As Integer
Dim ForeCastRange As Range
Dim ForecastWS As Worksheet
Dim SummaryWs As Worksheet
Dim PasteRange As Range
Dim ColumnCountSummary As Integer
Dim RowCountSummary As Integer
ColumnsCount = 300
ColCounter = 0
RowsCount1 = 0
RowsCount2 = 47
ColumnCountSummary = 0
RowCountSummary = 0
Do While ColCounter <= ColumnsCount
Worksheets("Sheet1").Select
Set ForeCastRange = Worksheets("Sheet1").Range("B2:KN49")
With ForeCastRange
.Range(.Cells(RowsCount1, ColCounter), .Cells(RowsCount2, ColCounter)).Copy
End With
Worksheets("Sheet2").Select
Set PasteRange = Worksheets("Sheet2").Range("J2:J13915")
With PasteRange
.Range(.Cells(RowCountSummary, ColumnCountSummary), .Cells(RowCountSummary + RowsCount2, ColumnCountSummary)).PasteSpecial
End With
RowCountSummary = RowCountSummary + 48
ColCounter = ColCounter + 1
Loop
End Sub
This behaviour has been encountered before and can seen with this simple demo
Sub test()
With Sheet1.Range("J3:J100")
Debug.Print .Range(.Cells(0, 0), .Cells(47, 0)).Address
End With
End Sub
which results in $R$4:$R$51. If you repeat run for the columns B to J the results are B,D,F,H,J,L,N,P showing the doubling effect. B is OK I think because of the zero column number.
You can probably fix your code by setting RowCountSummary = 1 and ColumnCountSummary = 1 and adding .parent
With PasteRange
.Parent.Range(.Cells(RowCountSummary, ColumnCountSummary), _
.Cells(RowCountSummary + RowsCount2, ColumnCountSummary)).PasteSpecial
End With
or you could try this
Sub InsertForecastData1()
Const columnCount As Integer = 3
Const rowCount As Integer = 48
Const sourceCol As String = "B"
Const targetCol As String = "J"
Const startRow As Integer = 2
Const records As Integer = 300
Dim rngSource as Range, rngTarget As Range
Dim start as Single, finish as Single
Set rngSource = Worksheets("Sheet1").Range(sourceCol & startRow)
Set rngSource = rngSource.Resize(rowCount, columnCount)
Set rngTarget = Worksheets("Sheet2").Range(targetCol & startRow)
start = Timer
Application.ScreenUpdating = False
Dim i As Integer
For i = 1 To records
'Debug.Print rngSource.Address, rngTarget.Address
rngSource.Copy rngTarget
Set rngSource = rngSource.Offset(rowCount, 0)
Set rngTarget = rngTarget.Offset(rowCount, 0)
Next i
Application.ScreenUpdating = True
finish = Timer
MsgBox "Completed " & records & " records in " & finish - start & " secs"
End Sub
See Remarks section the docs

How to insert current timestamp when cell value changes based on cell content

I have a drop-down list in a column B and I want to capture timestamps of changes made to that column based on different options available in drop-down and extract that timestamp to different columns
User can choose from the list and i have a macro that inputs timestamp of any change made.
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20180830
Dim xCellColumn As Integer
Dim xTimeColumn As Integer
Dim xRow, xCol As Integer
Dim xDPRg, xRg As Range
xCellColumn = 3
xTimeColumn =
xRow = Target.Row
xCol = Target.Column
If Target.Text <> "" Then
If xCol = xCellColumn Then
Cells(xRow, xTimeColumn) = Now()
Else
On Error Resume Next
Set xDPRg = Target.Dependents
For Each xRg In xDPRg
If xRg.Column = xCellColumn Then
Cells(xRg.Row, xTimeColumn) = Now()
End If
Next
End If
End If
End Sub
I am looking for a way to modify it, so that once user chooses "In-progress" timestamp is saved in column D, later that cell can be changed into "Closed" and timestamp of that should be presented in column E (respective row) but the value of Column D will stay the same.
I wanna trace timestamp of status changes.
You can use a switch for each of your outputs to determine the column (c), based on your change event, such that:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns(2)) Is Nothing Then Exit Sub
dim r as long, c as long
r = target.row
select case lcase(target.value)
case "in-progess"
c = 4
case "closed"
c = 5
case else
c = 0
end select
if c > 0 then cells(r,c).value = now()
end sub
untested code

Updating sheet automatically when a change is made - VBA Excel

I struggling to work out the logic to this so any help would be appreciated!
I have a sheet with names and dates, on each row (in the example column D to F) it needs to find the greatest date and then add a date to a column (column C). I can get this to work on a single test row, but I need it to work when there is a change on any row.
B C D E F
Name Due Date Date 1 Date 2 Date 3
Dave 01-01-20 01-01-14 01-01-17
Sarah 01-01-21 01-02-11 01-02-15 01-02-18
The code I have so far is:
LastRow = wsCB.Cells(Rows.Count, "C").End(xlUp).Row
rowcount = 12
Max_date = Application.WorksheetFunction.Max(wsCB.Range(wsCB.Cells(rowcount, 5), wsCB.Cells(rowcount, 10)))
Max_date = CDate(Max_date)
DueDate = DateAdd("yyyy", 3, Max_date)
wsCB.Cells(12, 4) = DueDate
I have set it to call on a Worksheet_Change. I have tried various loops trying to use xlup but I'm not sure this is the right way to go about it as I need the value to be updated when the user has typed in a new date for someone. I can't quite work out how to scale this single line example to the whole sheet.
The data won't be massive, however there will be 5 sheets like this with up to a maximum of 70 names on each sheet.
I'm still quite new to VBA so any advice would be very helpful!
The following VBA code should achieve your desired results:
Private Sub Worksheet_Change(ByVal Target As Range)
Select Case Target.Column
Case 4, 5, 6 'if user entered data in columns D to F
Max_date = Application.WorksheetFunction.Max(Range(Cells(Target.Row, 4), Cells(Target.Row, 6)))
'get the max value in row from column D to F (4 to 6)
Max_date = CDate(Max_date)
DueDate = DateAdd("yyyy", 3, Max_date)
Cells(Target.Row, 3) = DueDate
End Select
End Sub
Try this.
You'll just need to adjust columns to fit your needs
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MaxDate As Date, DueDate As Date
Dim CurRow As Long
Dim Ws As Worksheet
Set Ws = Target.Parent
CurRow = Target.Row
With Ws
MaxDate = CDate(Application.WorksheetFunction.Max(.Range(.Cells(CurRow, "D"),.Cells(CurRow, "F"))))
DueDate = DateAdd("yyyy", 3, MaxDate)
Application.EnableEvents = False
.Cells(CurRow, 3) = DueDate
Application.EnableEvents = True
End With
End Sub
My suggested code for your problem:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xCellColumnD As Long
Dim xCellColumnE As Long
Dim xCellColumnF As Long
Dim xDueColumn As Long
Dim xRow As Long, xCol As Long
xCellColumnD = 4
xCellColumnE = 5
xCellColumnF = 6
xDueColumn = 3
xRow = Target.Row
xCol = Target.Column
If Target.Text <> "" Then
If xCol = xCellColumnD Or xCol = xCellColumnE Or xCol = xCellColumnF Then
Max_date = Application.WorksheetFunction.Max(Range(Cells(xRow, 4), Cells(xRow, 6)))
Max_date = CDate(Max_date)
DueDate = DateAdd("yyyy", 3, Max_date)
Cells(xRow, xDueColumn) = DueDate
End If
End If
End Sub
I suggest to use Intersect in combination with a loop over the Target range so you are a bit more save against pasting a whole range of values.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = Target.Parent
If Not Intersect(Target, ws.Range("D:F")) Is Nothing Then
Dim MaxDate As Double
Dim DueDate As Variant
Dim iRow As Long
For iRow = Target.Row To Target.Row + Target.Rows.Count - 1
On Error Resume Next
MaxDate = Application.WorksheetFunction.Max(ws.Range(ws.Cells(iRow, "D"), ws.Cells(iRow, "F")))
If Err.Number <> 0 Then
DueDate = "#VALUE!"
ElseIf MaxDate = 0 Then
DueDate = vbNullString 'remove date if no dates
Else
DueDate = DateAdd("yyyy", 3, MaxDate)
End If
On Error GoTo 0
Application.EnableEvents = False 'prevents triggering change event again
ws.Cells(iRow, "C").Value = DueDate
Application.EnableEvents = True
Next iRow
End If
End Sub

assigning priority based on user dynamically changing values excel vba

I have list courses in cell b and their respective priorities in cell c from 1 to 49.
what I want is if a user changes any value of the priority column i.e. "C". then all other priority should be adjusted accordingly. logic can be seen in the attached sheet. the priority numbers should change dynamically as the user enters the value.
so in example one referring column L in the attached sheet.
if user change the no 4 priority to 8 then the rest will go one down .
similarly now we have got new nos list. so if any other number changes then it should adjust accordingly,keeping in mind the new list
sheet snapshot attached
Tried the below code but it always starts with the value 1 again. So the values are not adjusted based on new list.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myVal As Variant
Dim iCount As Long
Dim cell As Range
Dim myRange As Range
Set myRange = Worksheets("Sheet1").Range("C1:C49")
If Intersect(Target, Range("C1:C49")) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
Application.EnableEvents = False
myVal = Target.Value
iCount = 1
For Each cell In myRange
If Intersect(Target, cell) Is Nothing Then
If iCount = myVal Then
iCount = iCount + 1
End If
cell.Value = iCount
iCount = iCount + 1
End If
Next cell
Application.EnableEvents = True
End Sub
Edited to work when first row is any row
The following was generated ...
from this code ...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ExtVal As Variant, InsVal As Variant
Dim iLoop As Long
Dim InsRow As Long, ExtRow As Long
Dim foundArr() As Boolean
Dim myRange As Range
' initial settings
Set myRange = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
ReDim foundArr(1 To myRange.Rows.Count)
For iLoop = 1 To myRange.Rows.Count
foundArr(iLoop) = False
Next iLoop
If Intersect(Target, myRange) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
' calculate the extracted value - the user entered value
ExtVal = Target.Value
' calculate the inserted value - the number the user typed over
For iLoop = 1 To myRange.Rows.Count
foundArr(myRange.Cells(iLoop, 1).Value) = True
Next iLoop
For iLoop = 1 To myRange.Rows.Count
If Not foundArr(iLoop) Then
InsVal = iLoop
Exit For
End If
Next iLoop
' calculate the insertion row - the row the user typed in.
InsRow = CLng(Right(Target.Address, 1))
' calculate the extraction row - the original row of the number the user typed
ExtRow = 0
For iLoop = 1 To myRange.Rows.Count
If myRange.Cells(iLoop, 1).Value = ExtVal And myRange.Cells(iLoop, 1).Row <> InsRow Then
ExtRow = myRange.Cells(iLoop, 1).Row
Exit For
End If
Next iLoop
' do the swap / shuffle
Application.EnableEvents = False
For iLoop = myRange.Rows.Count To 1 Step -1
Debug.Print "Evaluating Row " & myRange.Cells(iLoop, 1).Row
If (myRange.Cells(iLoop, 1).Row <= ExtRow) Then
If myRange.Cells(iLoop, 1).Row > InsRow + 1 Then
myRange.Cells(iLoop, 1).Value = myRange.Cells(iLoop - 1, 1).Value
Else
If myRange.Cells(iLoop, 1).Row = InsRow + 1 Then
myRange.Cells(iLoop, 1).Value = InsVal
End If
End If
End If
Next iLoop
Application.EnableEvents = True
End Sub

Loop to create Object excel vba

I tried to get the unique value of each column in the range "RD" and display them in single column. I need to create an object ("scripting.Dictionary") where there are just as many as the number of columns in Range "RD". I tried this code but it resulted in "Run time error 13".
Private Sub CommandButton1_Click()
Range(Me.RefEdit1).Name = "RD"
Range(Me.RefEdit2).Name = "OT"
Dim d As Object, c As Variant, i As Long, s As Long
Dim JK As Long
Dim o As Collection
JK = Range("RD").Columns.Count
Set d = CreateObject("Scripting.Dictionary")
For k = 0 To JK + 1
d.Item(k) = CreateObject("Scripting.Dictionary").Item(k)
c = Range("RD").Columns(k + 1)
If d.Exists(k) Then
d.Item(k) = d.Item(k) + 1 'increment
Else
d.Item(k) = 1 'set as 1st occurence
End If
For i = 1 To UBound(c, 1)
d.Item(k)(c(i, 1)) = 1
Next i
Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count) = Application.Transpose(d.Item(k).Keys)
Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count).Sort Key1:=Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count)
Next k
End Sub
I'm adding some code below to help loop through a list, looking for unique values, and adding them to a new column. In my example, I enclose the entire functionality into a single loop for efficiency. I'm also adding the unique values to a new column in Sheet2 starting with cell A1.
Let me know if you need any additional help.
EDITED CODE BASED ON A MISUNDERSTANDING:
Private Sub CommandButton1_Click()
Dim oDict As Object
Dim rngToScrub As Range
Dim rngNewColumnToStoreUnique As Range
Dim oCol As Range
Dim cel As Range
Set rngToScrub = Range(Me.RefEdit1.Value)
Set rngNewColumnToStoreUnique = Sheet2.Range("A1")
For Each oCol In rngToScrub.Columns
Set oDict = CreateObject("Scripting.Dictionary")
For Each cel In oCol.Cells
If oDict.exists(cel.Value) Then
'Do Nothing for Now
Else
oDict.Add cel.Value, 0
rngNewColumnToStoreUnique.Value = cel.Value
Set rngNewColumnToStoreUnique = rngNewColumnToStoreUnique.Offset(1)
End If
Next cel
Set oDict = Nothing
Next oCol
End Sub
Old code: Misunderstood requirements
Private Sub CommandButton1_Click()
Dim oDict As Object
Dim rngToScrub As Range
Dim rngNewColumnToStoreUnique As Range
Dim cel As Range
Set oDict = CreateObject("Scripting.Dictionary")
Set rngToScrub = Range(Me.RefEdit1.Value)
Set rngNewColumnToStoreUnique = Sheet2.Range("A1")
For Each cel In rngToScrub
If oDict.exists(cel.Value) Then
'Do Nothing for Now
Else
oDict.Add cel.Value, 0
rngNewColumnToStoreUnique.Value = cel.Value
Set rngNewColumnToStoreUnique = rngNewColumnToStoreUnique.Offset(1)
End If
Next cel
End Sub

Resources