Set Variable equal to multiple selected cells - vba

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

Related

Clear contents of cells when the cell left of it changes

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

VBA save value from cell before it changes

I have a spreadsheet where i implement a score board.
The behavior i need is when the cell that has the score value rises the cell near it, on column b, changes it's color to green, when the the cell score value goes down the cell near it changes it's color to red.
The cell range where the score is changing is e5:e67
In short:
When the user inputs a number in column f, the score raises in column e, and in column b (on same row) the color must change to green or red
I made this VBA code, but without luck.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("e5:e67")) Is Nothing Then
If Target.Column = 5 Then
thisRow = Target.Row
Dim OldValue As Variant
Application.EnableEvents = False
Application.Undo
OldValue = Target.Value
Application.Undo
Application.EnableEvents = True
If OldValue < Target.Value Then
Range("b" & thisRow).Interior.ColorIndex = 4
ElseIf OldValue > Target.Value Then
Range("b" & thisRow).Interior.ColorIndex = 3
End If
End If
End If
End Sub
Here is a screen capture of my ranking sheet:
Try by intercepting the Worksheet_Calculate event. You need to save the old value in a static local array, that I call oldVal.
Private Sub Worksheet_Calculate()
Static oldVal
If IsEmpty(oldVal) Then
oldVal = Application.Transpose(Range("e5:e67").Value2)
ReDim Preserve oldVal(5 To 67)
Exit Sub
End If
Dim i As Long
For i = LBound(oldVal) To UBound(oldVal)
If oldVal(i) > Cells(i, "E").Value2 Then Cells(i, "B").Interior.ColorIndex = 3
If oldVal(i) < Cells(i, "E").Value2 Then Cells(i, "B").Interior.ColorIndex = 4
oldVal(i) = Cells(i, "E").Value2
Next
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
If Not Intersect(Target, Range("e6:e67")) Is Nothing Then
If Target.Offset(-1) < Target Then
i = 4
Else
i = 3
End If
Range("b" & Target.Row).Interior.ColorIndex = i
End If
End Sub

Auto-populate specific columns on excel based on selected menu using vba

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

Code for excel inventory to count returns

I'm not a VBA expert but I am working on a temp inventory control using excel with a barcode scanner. I am currently using the code below (which I took from here quantity macro excel for inventory) to add the qty on the worksheet, ex. barcodeA scanned 3x will automatically register as 3 pcs in my worksheet. I need a way to incorporate subtracting quantity as well. I'd like the ff conditions to apply:
Cell "A1" = scan cell to add qty to inventory
Cell "B1" = scan cell to remove qty from the inventory
Any advise on how to tweak the code? I've been trying to adjust for days but whatever I do just doesn't seem to work.
Private Sub Worksheet_Change(ByVal Target As Range)
Const SCAN_CELL As String = "A1"
Const RANGE_BC As String = "A5:A500"
Dim val, f As Range, rngCodes As Range
If Target.Cells.Count > 1 Then Exit Sub
If Intersect(Target, Me.Range(SCAN_CELL)) Is Nothing Then Exit Sub
val = Trim(Target.Value)
If Len(val) = 0 Then Exit Sub
Set rngCodes = Me.Range(RANGE_BC)
Set f = rngCodes.Find(val, , xlValues, xlWhole)
If Not f Is Nothing Then
With f.Offset(0, 1)
.Value = .Value + 1
End With
Else
Set f = rngCodes.Cells(rngCodes.Cells.Count).End(xlUp).Offset(1, 0)
f.Value = val
f.Offset(0, 1).Value = 1
End If
Application.EnableEvents = False
Target.Value = ""
Application.EnableEvents = True
Target.Select
End Sub
#Kazimierz beat me to it, but posting this anyway...
Private Sub Worksheet_Change(ByVal Target As Range)
Const SCAN_PLUS_CELL As String = "A1"
Const SCAN_MINUS_CELL As String = "B1"
Const RANGE_BC As String = "A5:A500"
Dim val, f As Range, rngCodes As Range, inc, addr
If Target.Cells.Count > 1 Then Exit Sub
Select Case Target.Address(False, False)
Case SCAN_PLUS_CELL: inc = 1
Case SCAN_MINUS_CELL: inc = -1
Case Else: Exit Sub
End Select
val = Trim(Target.Value)
If Len(val) = 0 Then Exit Sub
Set rngCodes = Me.Range(RANGE_BC)
Set f = rngCodes.Find(val, , xlValues, xlWhole)
If Not f Is Nothing Then
With f.Offset(0, 1)
.Value = .Value + inc 'should really check for 0 when decrementing
End With
Else
If inc = 1 Then
Set f = rngCodes.Cells(rngCodes.Cells.Count).End(xlUp).Offset(1, 0)
f.Value = val
f.Offset(0, 1).Value = 1
Else
MsgBox "Can't decrement inventory for '" & val & "': no match found!", _
vbExclamation
End If
End If
Application.EnableEvents = False
Target.Value = ""
Application.EnableEvents = True
Target.Select
End Sub
Try with this:
Private Sub Worksheet_Change(ByVal Target As Range)
Const SCAN_CELL As String = "A1"
Const SCAN_CELL_REMOVE As String = "B1"
Dim intAddRemoveExit As Integer
Const RANGE_BC As String = "A5:A500"
Dim val, f As Range, rngCodes As Range
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Me.Range(SCAN_CELL)) Is Nothing Then intAddRemoveExit = 1
If Not Intersect(Target, Me.Range(SCAN_CELL_REMOVE)) Is Nothing Then intAddRemoveExit = -1
If intAddRemoveExit = 0 Then Exit Sub
val = Trim(Target.Value)
If Len(val) = 0 Then Exit Sub
Set rngCodes = Me.Range(RANGE_BC)
Set f = rngCodes.Find(val, , xlValues, xlWhole)
If Not f Is Nothing Then
With f.Offset(0, 1)
.Value = .Value + intAddRemoveExit
End With
Else
Set f = rngCodes.Cells(rngCodes.Cells.Count).End(xlUp).Offset(1, 0)
f.Value = val
f.Offset(0, 1).Value = 1
End If
Application.EnableEvents = False
Target.Value = ""
Application.EnableEvents = True
Target.Select
End Sub
Please keep in mind that this solution doesn't check if product amount is higher then zero before removing. So, amount could go below zero.

Auto Formatting Race Result Times

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