I have a macro which is searching 3 worksheets for an invoice number that a user might enter (in total over 2.6 million records).
The numbers come in a single cell which also has a look up reference in it. form: invoicenumber, reference_letter.
Originally, that was fine because invoice numbers were 10 digits. Now they can be anything, but there is always a comma at the end, before single char reference.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$5" Then Exit Sub
If Target.Value = "" Then Exit Sub
Application.EnableEvents = False
Range("B5") = ""
For Each sh In Sheets
If sh.Name = ActiveSheet.Name Then GoTo 111
sh.Range("B1").FormulaArray = "=IFERROR(MATCH(Main!A5,LEFT(A:A,10),0),"""")"
If sh.Range("B1") <> "" Then
x = sh.Range("B1")
Range("B5") = Right(sh.Range("A" & x), 1)
Exit For
End If
111
Next sh
Application.EnableEvents = True
If x = "" Then MsgBox "Not Found!"
End Sub
I know that this 10 char restriction is in line 8, and I tried replacing with a FIND, but I don't think I had it right (on the basis that I couldn't get it to work!).
I'd be grateful for help in getting this sorted.
I have a further vLookup which is taking that last character and returning text from a separate sheet.
Try this
Private Sub Worksheet_Change(ByVal Target As Range)
Dim InvLen As Integer
If Target.Address <> "$A$5" Then Exit Sub
If Target.Value = "" Then Exit Sub
Application.EnableEvents = False
Range("B5") = ""
For Each sh In Sheets
If sh.Name = ActiveSheet.Name Then GoTo 111
InvLen = Len(Worksheets("Main").Range("A5").value)
sh.Range("B1").FormulaArray = "=IFERROR(MATCH(Main!A5,LEFT(A:A," & InvLen & "),0),"""")"
If sh.Range("B1") <> "" Then
x = sh.Range("B1")
Range("B5") = Right(sh.Range("A" & x), 1)
Exit For
End If
111
Next sh
Application.EnableEvents = True
If x = "" Then MsgBox "Not Found!"
End Sub
Related
I have a macro:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim v
If Target.Cells.Count <> 1 Then Exit Sub
If Target.Column <> 1 Then Exit Sub
v = Target.Value
If VarType(v) <> vbDate Then
Application.EnableEvents = False
If v Like "???##" Or v Like "???-##" Then Target.Value = Left(v, Len(v) - 2) & "20" & Right(v, 2)
If VarType(Target.Value) <> vbDate Then Target.Value = Empty
Target.NumberFormat = "m/d/yyyy"
Application.EnableEvents = True
End If
End Sub
When copying (ex: may20, may-20) from another column to column A in Excel itself with this macro, it allows to paste only once - the next cell is no longer pasted, apparently, the clipboard is cleared after the first paste. I have to copy again from another column. How it can be corrected?
See below - if you need to paste the same value again.
The core problem is that the change event always clears the clipboard - there's no (easy) way I'm aware of to prevent that.
Private Sub Worksheet_Change(ByVal Target As Range)
Const MNTH_NM As String = "[A-Z][A-Z][A-Z]" 'a bit better than "???"
Dim v
If Target.Cells.Count <> 1 Then Exit Sub
If Target.Column <> 1 Then Exit Sub
v = Target.Value
If Len(v) > 0 Then
Application.EnableEvents = False
If UCase(v) Like MNTH_NM & "##" Or UCase(v) Like MNTH_NM & "-##" Then
v = Left(v, 3) & "-20" & Right(v, 2)
Target.NumberFormat = "m/d/yyyy"
Target.Value = v
Target.Copy
Else
Target.ClearContents 'if doesn't match the pattern, clear it
End If
Application.EnableEvents = True
End If 'non-zero length
End Sub
I have 2 sheets in same workbook, one is data sheet and 2nd sheet contains the data validation values. I am facing problem while removing value from a cell (in data sheet) (which contains data validation). The issue is when I try to remove the value from validation list, the same value didn't remove from the cell. (see screen shot)
"e.g. if I want to remove volunteer name from the validation list, the value didn't delete from cell in data sheet (cell highlighted in screenshot)."
I have written a vba code to add multiple values in same cell separated by commas. I would appreciate if someone help me to solve this issue.
My VBA code is below:
Option Explicit
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 = 3 Or Target.Column = 4 Or Target.Column = 5 Or Target.Column = 6 Or
Target.Column = 7 Or Target.Column = 8 _
Or Target.Column = 9 Or Target.Column = 11 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
exitHandler:
Application.EnableEvents = True
End Sub
You can find the worksheet from the link below: (show1 Sheet is data sheet and Validation Fields contains the drop-down values)
Excel Sheet
Thanks
This code works for me:
Private Sub Worksheet_Change(ByVal Target As Range)
Const SEP As String = ","
Dim c As Range, NewValue As String, OldValue As String, arr, v, lst, removed As Boolean
On Error GoTo Exitsub
If Target.CountLarge > 1 Then Exit Sub '<< only handling single-cell changes
Select Case Target.Column
Case 3, 4, 5, 6, 7, 8, 9, 11
Set c = Target
Case Else: Exit Sub
End Select
If Len(c.Value) > 0 And Not c.Validation Is Nothing Then
Application.EnableEvents = False
NewValue = c.Value
Application.Undo
OldValue = c.Value
If OldValue = "" Then
c.Value = NewValue
Else
arr = Split(OldValue, SEP)
'loop over previous list, removing newvalue if found
For Each v In arr
If Trim(CStr(v)) = NewValue Then
removed = True
Else
lst = lst & IIf(lst = "", "", SEP) & v
End If
Next v
'add the new value if we didn't just remove it
If Not removed Then lst = lst & IIf(lst = "", "", SEP) & NewValue
c.Value = lst
End If
End If 'has validation and non-empty
Exitsub:
If Err.Number <> 0 Then MsgBox Err.Description
Application.EnableEvents = True
End Sub
I have encountered a few issues with some code in VBA. I am trying to have the changes made to a cells on an excel sheet show up in comments on the cell the change was made to and I wish for these changes to be stored in a list so I can view them all later. I have tried lots of different pieces of code I have found to try and implement it into the code but none have worked.
Any ideas on how to get this to work?
Worksheet
The below code is what I am currently using
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Adding As Boolean, Finding As Boolean, Subtracting As Boolean
Dim f As Range, v
Select Case Target.Address(True, True)
Case "$A$4": Adding = True
Case "$C$4": Subtracting = True
Case "$E$4": Finding = True
Case Else: Exit Sub
End Select
v = Trim(Target.Value)
If Len(v) = 0 Then Exit Sub
Set f = Me.Range("C8").Resize(1000, 1).Find(v, lookat:=xlWhole)
If Adding Then
If f Is Nothing Then
'not found: add as new row
Set f = Me.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
f.Value = v
End If
f.Offset(0, 1).Value = f.Offset(0, 1).Value + 1
doDate f.Offset(0, 2)
Target.Value = ""
ElseIf Subtracting Then
If f Is Nothing Then
MsgBox v & " not found for subtraction!"
Else
f.Offset(0, 1).Value = f.Offset(0, 1).Value - 1
doDate f.Offset(0, 3)
Target.Value = ""
End If
Else 'finding
If Not f Is Nothing Then
f.EntireRow.Select
Target.Value = ""
Else
MsgBox v & " not found."
End If
End If
If Adding Or Subtracting Then Target.Select
End Sub
Sub doDate(c As Range)
With c
.NumberFormat = "m/d/yyyy h:mm AM/PM"
.Value = Now
End With
End Sub
I have implemented a few formulas on the worksheet but don't see any reason why it would matter in this situation since they only track quantity of items with the same unique identifier.
I also tried some code that added comments to the cells as they were changed that worked but always returned the previous cell value as blank. It is not actually added into the current code though.
Option Explicit
Public preValue As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Target.ClearComments
Target.AddComment.Text Text:="Previous Value was " & preValue & Chr(10) & "Revised " & Format(Date, "mm-dd-yyyy") & Chr(10) & "By " & Environ("UserName")
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target = "" Then
preValue = "a blank"
Else: preValue = Target.Value
End If
End Sub
By and large, the code below should do what you want. I marveled at your use of A4 and C4 to express addition and subtraction. As it is, whatever you change in those two cells, apart from clearing them, will result in a quantity of 1 being added or subtracted. I would have expected that a quantity must be entered there which is processed. If the quantity is fixed at 1 the system appears too elaborate.
Anyway, here's the code. I guess you'll be able to modify it to better suit your needs.
Private Sub Worksheet_Change(ByVal Target As Range)
' 038
Dim LookUp As Variant ' subject
Dim Action As Variant ' add = 1, subtract = -1, find = 2
Dim Fnd As Range ' Result of Find method
Dim Txt As String ' comment text
With Target
If (.Row <> 4) Or (.CountLarge > 1) Then Exit Sub
LookUp = Cells(4, "E").Value
On Error Resume Next
Action = Array(0, 1, 0, -1, 0, 2)(.Column)
End With
If Action And (LookUp <> "") Then
' C8 to end of column C
With Range(Cells(8, "C"), Cells(Rows.Count, "C").End(xlUp))
Set Fnd = .Find(LookUp, .Cells(.Cells.Count), xlValues, xlWhole, xlByRows)
End With
End If
If Fnd Is Nothing Then
Select Case Action
Case -1
MsgBox """" & LookUp & """ not found.", vbInformation, "Can't subtract"
Action = -2
Case 2
MsgBox """" & LookUp & """ not found.", vbInformation, "No record"
Action = -2
Case Else
Set Fnd = Cells(Rows.Count, "C").End(xlUp).Offset(1)
Fnd.Value = LookUp
End Select
End If
With Fnd
If Abs(Action) <> 2 Then
With .Offset(0, 1)
If .Comment Is Nothing Then
.AddComment
Else
Txt = Chr(10)
End If
Txt = "Previous Qty = " & .Value & Chr(10) & _
"Revised " & Format(Date, "mm-dd-yyyy") & Chr(10) & _
"by " & Environ("UserName") & Txt
.Comment.Text Txt, 1, False
.Value = Val(.Value) + Action
With .Offset(0, 2)
.NumberFormat = "m/d/yyyy h:mm AM/PM"
.Value = Now
End With
End With
ElseIf Action = 2 Then
.EntireRow.Select
End If
End With
If Action <> 2 Then Target.Select
End Sub
I am hoping someone can help me (I have a very tight turn around time (48 hours). I have a multi-select drop-down in one of my columns in excel. The user can select and de-select values from a list of 12 values (They usually select no more than 2 at a time). What I want is then based on the values selected in that column, that it populates another multi-select drop down in a second column.
For example(not real example but I can't share values in real example):
Column A: Fruit, Vegetables, Meat, Dairy
(They can select any of the above, and are stored as (Fruit, Vegetables) in cell. They can come back and say they want to deselect Fruit and add Meat then it would be stored as (Vegetables, Meat).
Column B: Fruit options are (F1, F2, F3) Vegetables (V1, V2, V3) Meat (M1, M2, M3) and Dairy (D1, D2, D3) etc.
Data validation only works if an individual selects one option for Column A. What I want to work is that it recognizes there are 2 or more values in column A and then display the corresponding values in Column B in a drop-down for user to select that is also multi-select and also allows for edits.
Why am I doing this? I need to create a dashboard to display the number of times values in column A are selected and number of times values in column B are selected, and also which ones were not selected, having them all in one column I figured was easier rather than having a separate column for each value where user inputs an 'x' if applicable.
I am open to better ways to do this.
Any assistance would be greatly appreciated.
Thank you!
My code Thus far:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim strVal As String
Dim i As Long
Dim lCount As Long
Dim Ar As Variant
On Error Resume Next
Dim lType As Long
If Target.Count > 1 Then GoTo exitHandler
lType = Target.Validation.Type
If lType = 3 Then
Application.EnableEvents = False
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
If Target.Column = 7 Or Target.Column = 8 Or Target.Column = 12 Or Target.Column = 13 Then
If oldVal = "" Then
'do nothing
Else
If newVal = "" Then
'do nothing
Else
On Error Resume Next
Ar = Split(oldVal, ", ")
strVal = ""
For i = LBound(Ar) To UBound(Ar)
Debug.Print strVal
Debug.Print CStr(Ar(i))
If newVal = CStr(Ar(i)) Then
'do not include this item
strVal = strVal
lCount = 1
Else
strVal = strVal & CStr(Ar(i)) & ", "
End If
Next i
If lCount > 0 Then
Target.Value = Left(strVal, Len(strVal) - 2)
Else
Target.Value = strVal & newVal
End If
End If
End If
End If
End If
exitHandler:
Application.EnableEvents = True
End Sub
So it involves a bit of arduous coding but you can set validation in specific cells based on other cell values as follows (they are currently hard-coded)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call FillCombo(Target)
End Sub
Private Function FillCombo(ByVal Target As Range)
On Error GoTo ExitFunction
If Target.Cells.Count > 1 Then Exit Function
Dim ComboList As String, CLUpdate As Boolean: CLUpdate = False
Dim CLAll As String: CLAll = "Apples,Pears,Oranges"
Dim CLApp As String: CLApp = "Granny Smith,Pink Lady"
Dim CLPea As String: CLPea = "Bartlett,Comice"
Dim CLOra As String: CLOra = "Satsuma,Tangerine,Blood"
If WorksheetFunction.CountIf(Range("A2:A4"), "Apples") > 0 _
Then ComboList = ListJoin(ComboList, CLApp)
If WorksheetFunction.CountIf(Range("A2:A4"), "Pears") > 0 _
Then ComboList = ListJoin(ComboList, CLPea)
If WorksheetFunction.CountIf(Range("A2:A4"), "Oranges") > 0 _
Then ComboList = ListJoin(ComboList, CLOra)
If Not Application.Intersect(Target, Range("A2:A4")) Is Nothing Then
Call UpdateCombo(Target, CLAll)
End If
Call UpdateCombo(Range("A6"), ComboList)
ExitFunction:
End Function
Private Function UpdateCombo(ByVal Target As Range, ComboList As String)
With Target.Validation
.Delete
.Add Type:=xlValidateList, Formula1:=ComboList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
If InStr(ComboList, Target.Value) = 0 Then Target.Value = ""
End Function
Private Function ListJoin(Str1 As String, Str2 As String) As String
If Str2 = "" Then ListJoin = Str1
If Str1 = "" And ListJoin = "" Then ListJoin = Str2
If ListJoin = "" Then ListJoin = Str1 & "," & Str2
End Function
Having trouble with time formatting.
I have set the cell to custom format 00:00.
Currently in column A a date is inputted, this can be as 0300 which converts to 03:00 which is perfect or you can just enter 03:00.
I now have a problem if a user enters 03;00 as i need this to display 03:00
how can i ensure that all times are in the hh:mm format and not in hh;mm etc.
This needs to auto change on input for anything in column A, except what is the header (A1:A5) although this should not be affected.
Thanks
On your sheets change event you would place the following code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge = 1 And Target.Column = 1 And Target.Row > 5 Then
Target.Value2 = Replace(Target.Value2, ";", ":")
End If
End Sub
Explaining the code... it first checks to make sure that the change isn't on multiple cells (ie paste) and that the change is on column A below Row 5. If it does pass the conditional it simply replaces ; for :.
This does what i require.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim xStr As String
Dim xVal As String
Set rng1 = Range("A:A")
Set rng2 = Range("C:C")
Set rng3 = Range("I:I")
On Error GoTo EndMacro
If Application.Intersect(Target, Union(rng1, rng2, rng3)) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
If Target.Row < 5 Then Exit Sub
Application.EnableEvents = False
With Target
If Not .HasFormula Then
Target.Value = Replace(Target.Value, ";", ":")
Target.Value = Left(Target.Value, 5)
xVal = .Value
Select Case Len(xVal)
Case 1 ' e.g., 1 = 00:01 AM
xStr = "00:0" & xVal
Case 2 ' e.g., 12 = 00:12 AM
xStr = "00:" & xVal
Case 3 ' e.g., 735 = 07:35 AM
xStr = "0" & Left(xVal, 1) & ":" & Right(xVal, 2)
Case 4 ' e.g., 1234 = 12:34
xStr = Left(xVal, 2) & ":" & Right(xVal, 2)
Case 5 ' e.g., 12:45 = 12:45
xStr = Left(xVal, 2) & Mid(xVal, 2, 1) & Right(xVal, 2)
Case Else
Err.Raise 0
End Select
.Value = Format(TimeValue(xStr), "hh:mm")
End If
End With
Application.EnableEvents = True
Exit Sub
EndMacro:
Application.EnableEvents = True
End Sub
Thanks