I have started creating a VBA Macro that helps me add formatting to rows as I add them with a custom NumberFormat. But since My partner and I sometimes Enter item like "ss.00" and this messed up the cell. So I started writing out another Sub where it checks if its missing the semicolon. How can I add "0:" to the front of this value automatically where the cell would show "0:50.20", Everytime I do it, it ends up being a long number.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Cells.Count = 1 Then
If Target.Column = 1 Then
If Target.Row < 24 And Target.Row > 1 Then
Set FirstRow = Target.Offset(0, 1)
Set LastRow = Target.Offset(0, 11)
If Target.Value <> "" Then
For Each Cel In Range(FirstRow, LastRow)
Cel.NumberFormat = "m:ss.00;#"
Next
Else
If MsgBox("This will erase the row! Are you sure?", vbYesNo) = vbNo Then
Exit Sub
Else
For Each Cel In Range(FirstRow, LastRow)
Cel.ClearContents
Next
End If
End If
End If
End If
Const sCheckAddress As String = "B2:L24"
Dim rngIntersect As Range
On Error Resume Next
Set rngIntersect = Intersect(Me.Range(sCheckAddress), Target)
On Error GoTo 0
If Not (rngIntersect Is Nothing) Then
If Target.Value2 <> "" Then
If InStr(Target.Value2, ":") < 1 Then
End If
End If
End If
End If
End Sub
Maybe this would help you :
If InStr(Target.Value2, ":") < 1 Then
' ":" not found
Target.Value = CStr("0:" & Target.Value)
Else
' ":" found
'Nothing to add
End If
Related
I am attempting to get my code to work when multiple cells are selected/changed. I'm not too sure where to go from here as I'm having trouble setting a variable to a target when the target is a multi-cell selection.
An example of what I need would be: All cells in column 1 are selected and deleted, so subsequently I want all cells in column 2 to also be deleted. Instead the code returns an error and does not delete column 2 for any of the selected rows.
Here is the code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.ScreenUpdating = False
If Target.Column = 1 Then
Application.EnableEvents = False
Dim OldValue As String
Dim NewValue As String
NewValue = Target.Value
Application.Undo
OldValue = Target.Value
Target.Value = NewValue
Application.EnableEvents = True
If OldValue = "" Then
Exit Sub
Else
Application.EnableEvents = False
Target.Offset(0, 1).ClearContents
MsgBox "Contents related to this drop-down have been cleared"
End If
End If
Exithandling:
Application.EnableEvents = True
Exit Sub
Application.ScreenUpdating = True
End Sub
Something like this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, oldVal, newVal, i As Long, num As Long, c As Range
On Error GoTo haveError:
'only process the part of Target which overlaps with ColA...
Set rng = Application.Intersect(Target, Me.Columns(1))
'run some checks before proceeding...
If rng Is Nothing Then Exit Sub
If rng.Cells.Count = Me.Columns(1).Cells.Count Then Exit Sub 'ignore full-column operations
If rng.Areas.Count > 1 Then Exit Sub 'handling multiple areas will be more complex...
If Application.CountBlank(rng) = 0 Then Exit Sub 'no empty cells: nothing to do here
Application.EnableEvents = False
newVal = GetArray(rng)
Application.Undo
oldVal = GetArray(rng)
rng.Value = newVal
For Each c In rng.Cells
i = i + 1
If newVal(i, 1) = "" And oldVal(i, 1) <> "" Then
c.Offset(0, 1).ClearContents
num = num + 1
End If
Next c
If num > 0 Then MsgBox "Contents related to drop-down(s) have been cleared"
haveError:
If Err <> 0 Then Debug.Print Err.Description
Application.EnableEvents = True
End Sub
'normalizes the array vs. scalar returned when calling .Value
' on a multi- vs. single-cell range
Function GetArray(rng As Range)
Dim arr
If rng.Count > 1 Then
arr = rng.Value
Else
ReDim arr(1 To 1, 1 To 1)
arr(1, 1) = rng.Value
End If
GetArray = arr
End Function
I'm trying to get a piece of code that, when a cell in column 8 changes it deletes the value of cell next to it(column 9).
Well... That is the simple version
Column 8 and 9 are both dropdown lists, the dropdown list in column 9 is dependent on column 8. In column 9, multiple answers are necesary so i found a code on the internet that made that possible, but now the value in column 9 doesn't delete automatically when i change the value in column 8.
This piece of code below works, but only when i change 1 cell(in column 8) at the time. It doesn't work when i paste multiple Cells in Column 8 or when i select a cell in column 8 and then drag it down(from the lower right corner).
I don't have a lot of experience with coding and just can't seem to find the right solution for this.
Thanks to QHarr i got a bit further.
This is my second attempt:
Dim ClearC9 As String
Dim i As Long
For i = 2 To 1000
If Target.Cells.Count > 1 Then GoTo ClearC9
If Not Intersect(Target, Range("H" & i)) Is Nothing Then
Range("I" & i).ClearContents
End If
Next i
exitHandler:
Application.EnableEvents = True
Columns("I:I").EntireColumn.AutoFit
ClearC9:
Selection.Offset(, 1).ClearContents
First Attempt:
Dim i As Long
For i = 2 To 1000
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("H" & i)) Is Nothing Then
Range("I" & i).ClearContents
End If
This is the entire code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lUsed As Long
If Target.Count > 1 Then GoTo exitHandler
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Intersect(Target, rngDV) Is Nothing Then
'do nothing
Else
Application.EnableEvents = False
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
If Target.Column = 9 Then
If oldVal = "" Then
'do nothing
Else
If newVal = "" Then
'do nothing
Else
lUsed = InStr(1, oldVal, newVal)
If lUsed > 0 Then
If Right(oldVal, Len(newVal)) = newVal Then
Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
Else
Target.Value = Replace(oldVal, newVal & ", ", "")
End If
Else
Target.Value = oldVal _
& ", " & newVal
End If
End If
End If
End If
End If
Dim i As Long
For i = 2 To 1000
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("H" & i)) Is Nothing Then
Range("I" & i).ClearContents
End If
Next i
exitHandler:
Application.EnableEvents = True
Columns("I:I").EntireColumn.AutoFit
End Sub
The general pattern to to create an intersection range:
if it is Nothing then do nothing
otherwise loop over its cells
for example:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range, TheIntersection As Range, r As Range
' stuff
TheIntersection = Intersect(Target, rngDV)
If TheIntersection Is Nothing Then
' do nothing
Else
For Each r In TheIntersection
' do something
Next r
End If
End Sub
I am trying to auto-populate the next columns based on the selected dropdown option of the 1st column on excel.
Below sample of the initial code that I thought but it appears my approach is incorrect.
Private Sub WorksheetStore_Change(ByVal Target As Range)
Dim i As Integer
Dim intCol As Integer
intCol = shtStoreGroup.Range("A")
If Not IsEmpty(Target.value) And intCol > 1 And Target.Columns.Count = 1 And Target.Column = intCol And Target.Row > Start_Row Then
For i = Target.Row To Target.Row + Target.Rows.Count - 1
If shtStoreGroup.Columns(intCol).Rows(i).value = "Create" Then
shtStoreGroup.Columns(intCol + 2).Rows(i).value = "N/A"
shtStoreGroup.Columns(intCol + 3).Rows(i).value = "Test"
Next i
End If
End Sub
May be you're after this:
Private Sub Worksheet_Change(ByVal target As Range)
If Not ValidateTarget(target, 2) Then Exit Sub '<-- exit if function validating 'Target' returns 'False'
On Error GoTo EXITSUB ' <-- be sure to handle possible errors properly
Application.EnableEvents = False '<--| disable events handling not to run this sub on top of itself
Select Case UCase(target.Value)
Case "CREATE"
target.Offset(, 2).Value = "N/A"
target.Offset(, 3).Value = "Test"
Case "DELETE"
target.Offset(, 2).Value = "???"
target.Offset(, 3).Value = "Test??"
End Select
EXITSUB:
Application.EnableEvents = True '<--| restore events handling
End Sub
Function ValidateTarget(target As Range, Start_Row As Long) As Boolean
With target
If .columns.Count > 1 Then Exit Function
If .Column <> 1 Then Exit Function
If .Row <= Start_Row Then Exit Function
If IsEmpty(.Value) Then Exit Function
ValidateTarget = True
End With
End Function
place the above code in the relevant worksheet ("shtStoreGroup"?) code pane, and NOT in a normal module code pane
I don't think you need worksheet_change() function
with a combobox named cbTest I would do it like
Option Explicit
Sub fill()
cbTest.AddItem ("Value1")
cbTest.AddItem ("Value2")
End Sub
Private Sub cbTest_Change()
Select Case cbTest.Value
Case "Value1"
Cells(1, 1).Value = "Test"
Case "Value2"
Cells(1, 2).Value = "Test2"
End Select
End Sub
Currently working on an excel sheet to rank projects, we would like it to automatically increase the numbers if we insert a new line and input an existing number rank. If we put in a line and type in 9 for its rank we want the pre existing 9 to move to 10 and the old 10 to move to 11 etc. I have kind of worked it out, however my code automatically numbers the first row as 1 and so forth. This is what I have so far.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Integer
I = 1
Application.EnableEvents = False
For I = 1 To 20
Range("A" & I).Value = I
Next
Range("A21").Value = ""
Application.EnableEvents = True
End Sub
You could loop through every cell in column A and, if its value is greater than (or equal to) the one just changed, increment it by one:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Long
Dim v As Long
Dim r As Range
Set r = Application.Intersect(Range("A:A"), Target)
If r Is Nothing Then
Exit Sub
End If
If r.Count > 1 Then
Exit Sub
End If
If IsEmpty(r.Value) Then
Exit Sub
End If
I = 1
v = r.Value
If Application.CountIf(Range("A:A"), v) > 1 Then ' Only change things if this
' value exists elsewhere
Application.EnableEvents = False
For I = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(I, "A").Address <> r.Address Then
If IsNumeric(Cells(I, "A").Value) Then ' skip cells that aren't numeric
If Cells(I, "A").Value >= v Then
Cells(I, "A").Value = Cells(I, "A").Value + 1
End If
End If
End If
Next
Application.EnableEvents = True
End If
End Sub
Screen shot of what I want:
I want to time stamp each line as a change gets made so I can upload to a central file all lines that have been updated after a certain time. Since one asset might have multiple rows for each sub component, the user can fill in one line and autofill/copy paste to the relevant lines beneath. The rows might not be in a continuous range (e.g. when filtered).
The code I've got works great for changing one cell at a time and it works for a range but incredibly slowly.
This sub is called by worksheet_change shown in full below.
Sub SetDateRow(Target As Range, Col As String)
Dim TargetRng As Range
Dim LastCol, LastInputCol As Integer
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 24
End With
For Each TargetRng In Target.Cells
If TargetRng.Cells.Count > 1 Then
Application.EnableEvents = True
Exit Sub
Else
Application.EnableEvents = False
Cells(TargetRng.Row, LastCol - 2) = Now()
Cells(TargetRng.Row, LastCol - 1).Value = Environ("username")
Cells(TargetRng.Row, LastCol).Value = Target.Address
End If
Next
Application.EnableEvents = True
End Sub
Target.Cells.Address returns the range (including non-visible cells), but I can't work out how to split this into individual, visible cells that I can loop through.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Errorcatch
Dim TargetRng As Range
Dim LastCol, LastInputCol, LastRow As Integer
Dim LastInputColLetter As String
Dim ContinueNewRow
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 24
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
LastInputCol = LastCol - 3
If LastInputCol > 26 Then
LastInputColLetter = Chr(Int((LastInputCol - 1) / 26) + 64) & Chr(((LastInputCol - 1) Mod 26) + 65)
Else
LastInputColLetter = Chr(LastInputCol + 64)
End If
For Each TargetRng In Target.Cells
If TargetRng.Row <= 2 Then
Exit Sub
End If
If TargetRng.Column <= LastInputCol Then
SetDateRow Target, LastCol - 3
If TargetRng.Count = 1 Then
Application.EnableEvents = False
'
Dim cmt As String
' If Target.Value = "" Then
' Target.Value = " "
'
' End If
'----------------------------------------------------------------
If Intersect(TargetRng, Range("AC3:AC10000")) Is Nothing Then ' need to make column into variables in the code based on column name
Application.EnableEvents = True
Else
Application.EnableEvents = False
Cells(TargetRng.Row, "Z") = Now() 'Date booking was made column
Cells(TargetRng.Row, "AD").Value = Cells(Target.Row, "AD").Value + 1 ' iteration column
End If
'----------------------------------------------------------------
If TargetRng.Comment Is Nothing Then
cmt = Now & vbCrLf & Environ("UserName") & " *" & TargetRng.Value & "*"
Else
cmt = Now & vbCrLf & Environ("UserName") & " *" & TargetRng.Value & "* " & TargetRng.Comment.Text
End If
With TargetRng
.ClearComments
.AddComment cmt
End With
End If
End If
Application.EnableEvents = True
Next
Exit Sub
Errorcatch:
MsgBox Err.Description
Application.EnableEvents = True
End Sub
I have done some adjustments to your code (see comments within code)
This solution assumes the following:
Sample data has a two rows header and fields to be updated have the following titles located at row 1 (adjust corresponding lines in code if needed):
Date Change Made, Who Made Change and Last Cell Changed as per picture provided.
Booked Date, BkdDte Change and Iteration for columns AC, Z and AD respectively (this names are used for testing purposes, change code to actual names)
I have also combined both procedures into a common one in order to avoid the inefficient approach of looping twice the cells of the changed range. Let me know if they must remain separated and will do the necessary adjustments.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Wsh As Worksheet, rCll As Range
Dim iDteChn As Integer, iWhoChn As Integer, iLstCll As Integer
Dim iBkdDte As Integer, iBkdChn As Integer, iBkdCnt As Integer
Dim sCllCmt As String
Dim lRow As Long
On Error GoTo ErrorCatch
Rem Set Application Properties
Application.ScreenUpdating = False 'Improve performance
Application.EnableEvents = False 'Disable events at the begining
Rem Set Field Position - This will always returns Fields position
Set Wsh = Target.Worksheet
With Wsh
iDteChn = WorksheetFunction.Match("Date Change Made", .Rows(1), 0)
iWhoChn = WorksheetFunction.Match("Who Made Change", .Rows(1), 0)
iLstCll = WorksheetFunction.Match("Last Cell Changed", .Rows(1), 0)
iBkdDte = WorksheetFunction.Match("Booked Date", .Rows(1), 0) 'Column of field "Booked date" (i.e. Column `AC`)
iBkdChn = WorksheetFunction.Match("BkdDte Change", .Rows(1), 0) 'Column of field "Booked date changed" (i.e. Column `Z`)
iBkdCnt = WorksheetFunction.Match("Iteration", .Rows(1), 0) 'Column of field "Iteration" (i.e. Column `AD`)
End With
Rem Process Cells Changed
For Each rCll In Target.Cells
With rCll
lRow = .Row
Rem Exclude Header Rows
If lRow <= 2 Then GoTo NEXT_Cll
Rem Validate Field Changed
Select Case .Column
Case Is >= iLstCll: GoTo NEXT_Cll
Case iDteChn, iWhoChn, iBkdChn, iBkdCnt: GoTo NEXT_Cll
Case iBkdDte
Rem Booked Date - Set Count
Wsh.Cells(lRow, iBkdChn) = Now()
Wsh.Cells(lRow, iBkdCnt).Value = Cells(.Row, iBkdCnt).Value + 1
End Select
Rem Update Cell Change Details
Wsh.Cells(lRow, iDteChn).Value = Now()
Wsh.Cells(lRow, iWhoChn).Value = Environ("username")
Wsh.Cells(lRow, iLstCll).Value = .Address
Rem Update Cell Change Comments
sCllCmt = Now & vbCrLf & Environ("UserName") & " *" & .Value & "*"
If Not .Comment Is Nothing Then sCllCmt = sCllCmt & .Comment.Text
.ClearComments
.AddComment sCllCmt
End With
NEXT_Cll:
Next
Rem Restate Application Properties
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
ErrorCatch:
MsgBox Err.Description
Rem Restate Application Properties
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Do let me know of any questions you might have about the resources used in this procedure.
You could use something like this:
Sub SetDateRow(Target As Range, Col As String)
Dim TargetRng As Range
Dim LastCol As Long
Dim LastInputCol As Long
Dim bEvents As Boolean
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 24
End With
bEvents = Application.EnableEvents
Application.EnableEvents = False
If Target.Cells.Count > 1 Then
For Each TargetRng In Target.SpecialCells(xlCellTypeVisible).Areas
Cells(TargetRng.Row, LastCol - 2).Resize(TargetRng.Rows.Count, 1).Value = Now()
Cells(TargetRng.Row, LastCol - 1).Resize(TargetRng.Rows.Count, 1).Value = Environ("username")
Cells(TargetRng.Row, LastCol).Resize(TargetRng.Rows.Count, 1).Value = Target.Address
Next
Else
Cells(Target.Row, LastCol - 2).Value = Now()
Cells(Target.Row, LastCol - 1).Value = Environ("username")
Cells(Target.Row, LastCol).Value = Target.Address
End If
Application.EnableEvents = bEvents
End Sub
but make sure you call it before or after the loop in your change event, not inside it as you are now!