I have the code below, which will be dependent on triggers, column A and B, to indicate timestamps for each completed entry, however, i keep on getting a runtime error 1004 pop-up:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A2:B501")) Is Nothing Then
Target.Offset(0, 12) = Now
Target.Offset(1, 13) = Now
Target.Offset(0, 14) = Environ("UserName")
End If
End Sub
I'm new to doing VBA, hopefully you guys can help me.
Better way to handle this is something like:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Application.Intersect(Target, Me.Range("A2:B501"))
'Work with "rng", not "Target", since Target might contain cells
' outside of ColA or B...
If Not rng Is Nothing Then
'Target (and so rng) could contain multiple cells
' so need to address them individually
For Each c In rng.Cells
'EDIT:
c.Offset(0, 12) = Now 'ColA >> M, ColB >> N
c.EntireRow.Cells(1, "O") = Environ("UserName")
Next c
End If
End Sub
However since you're handling both ColA and ColB there's a chance you may end up overwriting values since the ranges offset from A and B will overlap
Related
I'm currently learning the automatically triggered macro for a cell. I am curious if this can apply to a range of cells instead of 1 by 1?
My case is: If I input in any cell in column A, "Hello" will appear in column B in the corresponding row. My question is that what if, for instance, I input in A1 (then B1 will appear "Hello"), then I drag from A1 to A10, how can I make the macro automatically apply to B2 -> B10? Currently, I run into the "run time error '13' - Type mismatch".
My current script:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
i = Target.Row
If Not Intersect(Target, Range("A:A")) Is Nothing Then
If Target <> "" Then
Cells(i, 2) = "Hello"
Else
Cells(i, 2).ClearContents
End If
End If
End Sub
Use Offset, which is relative, and loop through Target if it is multiple cells.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer, r As Range
If Not Intersect(Target, Range("A:A")) Is Nothing Then
For Each r In Intersect(Target, Range("A:A")
If r <> "" Then
r.Offset(, 1).Value = "Hello"
Else
r.Offset(, 1).ClearContents
End If
Next r
End If
End Sub
So right now I have an excel workbook for a task tracker. When the column that contains the completed date is filled in, it will take that row and copy it onto another sheet ("Complete") then delete it off the current sheet ("Current"). What I would like it to do before this is executed is check the values of columns H through M for either a "C" or "U". If any of the Cells in that range do not contain either or, then I want it to exit out and display a message. I am not to familiar with Excel or VBA, but decent with C++.
Here is the code as of right now:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim receivedDate As Range, nextOpen As Range, isect As Range
Set receivedDate = Sheet1.Range("G3:G166")
Set isect = Application.Intersect(Target, receivedDate)
If Not (isect Is Nothing) And IsDate(Target) = True Then
Set nextOpen = Sheet4.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Target.EntireRow.Copy Destination:=nextOpen.EntireRow
Target.EntireRow.Delete
End If
Application.EnableEvents = True
End Sub
Here is snip of what I have going on...
snip of work
Any help would be greatly appreciated. Sorry I tried looking around some.
Edit - more robust, added error handler and multi-cell update handling
Private Sub Worksheet_Change(ByVal Target As Range)
Dim receivedDate As Range, nextOpen As Range, isect As Range
Dim rngHM As Range, c As Range, rngDel As Range
Set receivedDate = Sheet1.Range("G3:G166")
'are any of the changed cells in the range we're monitoring?
Set isect = Application.Intersect(Target, receivedDate)
On Error GoTo haveError 'error handler ensures events get re-enabled...
'### remember that Target can contain >1 cell...
For Each c In isect.Cells
If IsDate(c.Value) Then
With c.EntireRow
Set rngHM = .Cells(1, "H").Resize(1, 6)
'EDIT: all cells must be C or U
If (Application.CountIf(rngHM, "C") + _
Application.CountIf(rngHM, "U")) <> rngHM.Cells.Count Then
MsgBox "No C or U on row " & c.Row & " !"
Else
Set nextOpen = Sheet4.Range("A" & Rows.Count) _
.End(xlUp).Offset(1, 0)
.Copy Destination:=nextOpen.EntireRow
'deleting rows while looping gives odd results,
' so store them up until done...
If rngDel Is Nothing Then
Set rngDel = c
Else
Set rngDel = Application.Union(rngDel, c)
End If
End If
End With 'entirerow
End If 'is date
Next c
'delete any copied rows in a single operation
If Not rngDel Is Nothing Then
Application.EnableEvents = False
rngDel.EntireRow.Delete
Application.EnableEvents = True
End If
Exit Sub
haveError:
'if your code errors out then this makes sure event handling gets reset
Application.EnableEvents = True
End Sub
I am looking to do the following using Excel:
Below is a table of booleans and unique identifiers.
This is what I would like to achieve. If the first column says "No", I would like the code to automatically add a whole new row in a separate spreadsheet with the unique identifier in the first column of the new row (shown below is spreadsheet 1).
In this case C4 and C5 would be the two rows exemplified below (spreadsheet 2).
Code updated:
Sub AddID()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
Set Source = ActiveWorkbook.Worksheets("Questionnaire")
Set Target = ActiveWorkbook.Worksheets("AI Tracker")
j = 1
For Each c In Source.Range("C4:C54")
If c = "No" Then
Target.Cells(j + 4, "A").Value = c.Offset(, 1).Value
j = j + 1
End If
Next c
End Sub
This updates the target worksheet correctly but I need it to do update if the Source worksheet is altered (i.e. if something is changed to No, the function should add the new row to the Target sheet).
I have made the following code to detect changes but it does not work:
Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, ActiveWorkbook.Worksheets("Questionnaire").Range("C4:C54")) _
Is Nothing Then
Call Module2.AddID
MsgBox "Cell has changed"
End If
End Sub
instead of
Source.Rows(c.Row).Copy Target.Rows(j)
use
Target.Cells(j,"A").Value = c.Offset(,1).value '<~~ change "A" column index to whatever you need to be copied Unique identifier into
edited
following your further needs and the solution you posted 1 hour ago, consider the following optimization
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, ActiveWorkbook.Worksheets("Questionnaire").Range("C4:C54")) Is Nothing Then Exit Sub '<~~ use just one row and avoid the "Else-End If" block. it increases readability
Dim dest As Worksheet '<~~ Dim only if needed, i.e. if you didn't exit the sub
Set dest = ActiveWorkbook.Worksheets("AI Tracker") '<~~ Set only if needed,i.e. if you didn't exit the sub
If Target.Value = "No" Then dest.Range("A" & dest.Rows.Count).End(xlUp).Offset(1).Value = Target.Offset(, 1).Value '<~~ Target has already all you need and it's already a range
End Sub
still it remains to deal with some conditions. for instance: what if Target is a multiple cells Range?
Things were greatly simplified and I have come up with the following solution:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim n
Dim a
Set dest = ActiveWorkbook.Worksheets("AI Tracker")
If Intersect(Target, ActiveWorkbook.Worksheets("Questionnaire").Range("C4:C54")) Is Nothing Then
Exit Sub
Else
a = Target.Address
n = Range(a).Offset(, 1).Value
If Target.Value = "No" Then
dest.Range("A" & Rows.Count).End(xlUp).Offset(1).Value = n
End If
End If
End Sub
This will detect a "No" and then find the next empty row in the destination worksheet and add the Unique Identifier (associated with the "No") to the first cell in that row.
This is my first time to write a code and i try to write a code thats helps me to fill Columns B, C and D Automatically thats will happen when i fill Column A by myself.
this is the picture of that sheet i work on it now
Worksheet Explaining what i Want
The final result must be like this Picture
i try to google the code and i found a code but it not work at all
This is the first code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
r.Offset(0, 1).Value = Date
Next r
Application.EnableEvents = True
End Sub
also i try to write another code thats may helps me to fill Column B and C based on above code results but still not work.
This is the code written by me
Private Sub Worksheet_Change1(ByVal Target As Range)
Dim i As Integer
For i = 6 To 1000
If Cells(i, "A").Value <> "" And Cells(i, "B").Value <> "" Then
Cells(i, "C").Value = Date
Cells(i, "C").NumberFormat = "mmm"
Cells(i, "D").Value = Date
Cells(i, "D").NumberFormat = "yyyy"
End If
Next
Range("C:C").EntireColumn.AutoFit
Range("D:D").EntireColumn.AutoFit
End Sub
anyone can help with that?
The Worksheet_Change event macro is triggered when one or more cells on the worksheet changes value. If you write values into the worksheet within the Worksheet_Change procedure (like you are with the dates) without first turning off event handling then another Worksheet_Change is triggered and the procedure tries to run on top of itself. Always turn off event handling with Application.EnableEvents = False before writing values to the worksheet.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:B")) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
Dim rw As Long, rng As Range
For Each rng In Intersect(Target, Range("A:B"))
If Application.CountA(Cells(rng.Row, "A").Resize(1, 2)) = 2 Then
Cells(rng.Row, "C").Resize(1, 2).Value = Date
Cells(rng.Row, "C").NumberFormat = "mmmm"
Cells(rng.Row, "D").NumberFormat = "yyyy"
End If
Next rng
Range("C:C").EntireColumn.AutoFit
Range("D:D").EntireColumn.AutoFit
End If
bm_Safe_Exit:
If CBool(Val(Err.Number)) Then _
Debug.Print Err.Number & ": " & Err.Description
Application.EnableEvents = True
End Sub
Remember to turn events back on with Application.EnableEvents = True before exiting the Worksheet_Change procedure or future value changes will not trigger the Worksheet_Change procedure again.
btw, the correct number format for October is mmmm, not mmm. The former gives the full month name; the latter only the three letter abbreviation (e.g. Oct).
I have two ranges of data that I want to compare with and format if they match. So I want to format a range 1 cell if any of that data matches to the the data in range 2. This is what I have so far - it works until I change the data to range 2 but doesn't update it:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim myRange As Range, cell As Range
Set myRange = Range("a9:a12")
For Each cell In myRange
If cell.Value = ActiveCell.Value And Not IsEmpty(ActiveCell.Value) Then
ActiveCell.Interior.ColorIndex = 3
End If
Next cell
End Sub
The problem is the cell still stays the colors that it was formatted from the first block of code so how can I change it back if the data in the second range gets changed?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRange1 As Range
Set myRange1 = Range("f9:f12")
If Not Intersect(Target, Range("f1:f6")) Is Nothing Then
If Application.WorksheetFunction.CountIf(myRange1, ActiveCell.Value) > 0 _
Then ActiveCell.Interior.ColorIndex = 3 Else ActiveCell.Interior.Color = xlNone
End If
End Sub
Is this what you are trying?
If cell.Value = ActiveCell.Value And _
Not IsEmpty(ActiveCell.Value) Then
ActiveCell.Interior.ColorIndex = 3
Else
ActiveCell.Interior.Color = xlNone
End If
EDIT
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim myRange As Range
Set myRange = Range("a9:a12")
If Application.WorksheetFunction.CountIf(myRange, ActiveCell.Value) > 0 _
Then ActiveCell.Interior.ColorIndex = 3 Else ActiveCell.Interior.Color = xlNone
End Sub
EDIT
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRange As Range
Set myRange = Range("f9:f12")
If Not Intersect(Target, myRange) Is Nothing Then
If Application.WorksheetFunction.CountIf(myRange, Target.Value) > 0 _
Then Target.Interior.ColorIndex = 3 Else Target.Interior.Color = xlNone
End If
End Sub
You seem to be taking a somewhat inefficient route with your loop and are ignoring one of the tools (e.g. Target) that is being provided to you.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'important for _SelectionChange event macros
'only process the cells to the extents of the data, not whole rows or columns
If Not Intersect(Target, Target.Parent.UsedRange) Is Nothing Then
Dim c As Range
For Each c In Intersect(Target, Target.Parent.UsedRange)
c.Interior.ColorIndex = 3 + _
4145 * IsError(Application.Match(c.Value2, Range("A9:A12"), 0))
Next c
End If
End Sub
For a Worksheet_SelectionChange event macro, the Target represents one or more cells that is the current Selection. By cycling through each of the cells in the current selection, you can perform this pseudo-Conditional Formatting on a larger range. The Target or Selection can be any number of cells up to the total number of cells in a worksheet but the ActiveCell property can only ever be a single cell.
I've reduced the color on/color off switch to a single worksheet MATCH function and a little maths. This does away with looping through the criteria cells.
Because you may want to select entire row(s) or column(s) at some point, I've included a cell processing 'limit' that will process to the extents of the data on the worksheet. Without a cap on the cells to process, it is very easy to get caught up in the unnecessary processing of entire rows or columns of blank cells when using Worksheet_SelectionChange.