I'm using this code
Private Sub ComboBox2_Change()
On Error Resume Next
Dim myRange As Range
Set myRange = Worksheets("cash").Range("BF:BH")
Price.Value = Application.WorksheetFunction.VLookup(ComboBox2.Value, myRange, 2, 0)
End Sub
Select value from textbox2 using vlookup to match value selected from textbox2 in price. If the value is not included in textbox2 there is last price shown.
I need if I entered value not in range no price shown.
Clear the value before trying to do the Vlookup.
Also when using On Error Resume Next turn the error handling back on as soon as possible.
Private Sub ComboBox2_Change()
Dim myRange As Range
Set myRange = Worksheets("cash").Range("BF:BH")
Price.Value = ""
On Error Resume Next
Price.Value = Application.WorksheetFunction.VLookup(ComboBox2.Value, myRange, 2, 0)
On Error Goto 0
End Sub
Related
I am trying to use regular expressions in VBA to search in a specific file sheet.
I am trying to filter certain data.
I believe there is an issue with how to set my worksheet to the required value.
Dim RE As Object
Dim LSearchRow As Long
Dim LCopyToRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Values")
On Error GoTo Err_Execute
Set RE = CreateObject("vbscript.regexp")
RE.Pattern = "(T04)"
RE.Ignorecase = True
LSearchRow = 5 'Start search in row 5
LCopyToRow = 3 'Start copying data to row 2 in Sheet2 (row counter variable)
While Len(Cells(LSearchRow, "A").Value) > 0
If RE.test(Cells(LSearchRow, "H").Value) Then
'i believe this is the problem area, If i use active.Rows there isnt an issue
ws.Rows(LSearchRow).Copy Sheets("Filtered T04").Rows(LCopyToRow)
LCopyToRow = LCopyToRow + 1 'Move counter to next row
End If
LSearchRow = LSearchRow + 1
Wend
Range("A3").Select 'Position on cell A3
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
You need to properly refer to your set ws. Lines like:
While Len(Cells(LSearchRow, "A").Value) > 0
Will refer to the currently ActiveSheet. So, my guess is that you want to use the below:
Sub Test()
Dim RE As Object
Dim LSearchRow As Long
Dim LCopyToRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Values")
'On Error GoTo Err_Execute
Set RE = CreateObject("vbscript.regexp")
RE.Pattern = "(T04)"
RE.Ignorecase = True
LSearchRow = 5 'Start search in row 5
LCopyToRow = 3 'Start copying data to row 2 in Sheet2 (row counter variable)
While Len(ws.Cells(LSearchRow, "A").Value) > 0
If RE.Test(ws.Cells(LSearchRow, "H").Value) Then
ws.Rows(LSearchRow).Copy Sheets("Filtered T04").Rows(LCopyToRow) 'i believe this is the problem area, If i use active.Rows there isnt an issue
LCopyToRow = LCopyToRow + 1 'Move counter to next row
End If
LSearchRow = LSearchRow + 1
Wend
ws.Range("A3").Select 'Position on cell A3
MsgBox "All matching data has been copied."
Exit Sub
'Err_Execute:
'MsgBox "An error occurred."
End Sub
The above code runs/works, but make sure you haven't made an error in naming your ws variable. If you still hit an error please let us know what line it occurs.
Note: Just one thing I would do in your case is look into AutoFilter as an alternative to RegEx since you don't really use a regular expression but rather need to know if a substring exists in a cell. This would eliminate the need of iteration
I put together a regex function that will remove all whitespace from a column, and when I use it on a sheet I just have to type in =simplecellregex() then I run that in the new column against all of the entries. The reason I am doing it this way is because TRIM() does not work always so I looked for a way that did.
Function simpleCellRegex(Myrange As Range) As String
Dim Regex As New RegExp
Dim strPattern As String
Dim strInput As String
Dim strReplace As String
Dim strOutput As String
strPattern = "\s+$"
If strPattern <> "" Then
strInput = Myrange.Value
strReplace = ""
With Regex
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = strPattern
End With
If Regex.Test(strInput) Then
simpleCellRegex = Regex.Replace(strInput, strReplace)
Else
simpleCellRegex = strInput
End If
End If
End Function
Sub regex1()
Column.Add
Range("D2").Value = simpleCellRegex(Myrange, String)
End Sub
So this was the setup so that whenever I get workbooks I just click the column I want the function to run on and it runs the regex and spits it out the the column next to it. The plan is to make this a macro so I can just add a button on the excel menu ribbon and make this regex easy to run.
EDIT:
Use the following if you want to select a range and then press a button
Option Explicit
Public Sub RemoveEndWhiteSpace()
Dim arr(), i As Long, myRange As Range
Set myRange = Selection
If myRange.Columns.Count > 1 Or myRange Is Nothing Then Exit Sub
If myRange.Count = 1 Then
myRange = RTrim$(myRange.Value)
Exit Sub
Else
arr = myRange.Value
For i = LBound(arr, 1) To UBound(arr, 1)
arr(i, 1) = RTrim$(arr(i, 1))
Next i
myRange = arr
End If
End Sub
To output to a different column:
myRange.Offset(, 1) = arr '<==use offset to put result in a different column e.g. one to the right
Example run of the last bit of code tied to a button (where macro is set to all open workbooks btw)
tl;dr;
If you want to click on a column and trailing white space be removed something like the following. This uses a worksheet event of when you select a column to run the sub. The sub checks how many cells are populated in the column and works with those.
Private Sub Worksheet_SelectionChange would go in the code pane for the sheet you are wanting to do the replacement on.
.UsedRange is not always the most reliable method.
The sub it calls would go in a standard module. I suspect there are more efficient ways to do this to be honest but thought I would have a quick play.
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count = Columns(1).Cells.Count And Target.Columns.Count = 1 Then
'MsgBox "running"
RemoveEndWhiteSpace Intersect(Target, Me.UsedRange)
End If
End Sub
Public Sub RemoveEndWhiteSpace(ByVal myRange As Range)
Dim arr(), i As Long
If myRange.Count = 1 Then
myRange = RTrim$(myRange.Value)
Exit Sub
Else
arr = myRange.Value
For i = LBound(arr, 1) To UBound(arr, 1)
arr(i, 1) = RTrim$(arr(i, 1))
Next i
myRange = arr
End If
End Sub
More reliable for used range of column would be:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count = Columns(1).Cells.Count And Target.Columns.Count = 1 Then
' MsgBox "running"
Dim lastRow As Long, myRange As Range
lastRow = Cells(Rows.Count, Target.Column).End(xlUp).Row
Set myRange = Range(Cells(1, Target.Column), Cells(lastRow, Target.Column))
RemoveEndWhiteSpace myRange
End If
End Sub
I want to make a data validation list from text only in a Range of cells.
I searched for formula but I found nothing so I decided to make my own function but its not working.
I tried those codes:
Code 1:
Function ListFromRange(rng As Range) As Range
Dim cl As Range
Dim entry As Range
For Each cl In rng
If Not IsNumeric(cl.Value) Or cl.Value = "" Then
If entry Is Nothing Then
Set entry = cl
Else
Set entry = Union(entry, cl)
End If
End If
Next
Set ListFromRange = entry
End Function
Code 2:
Function ListFromRange2(rng As Range) As Variant
Dim cl As Range
Dim i As Integer
Dim entry() As String
ReDim entry(rng.Count)
For Each cl In rng
If Not IsNumeric(cl.Value) Or cl.Value = "" Then
entry(i) = cl.Value
i = i + 1
End If
Next
ListFromRange2 = entry
End Function
The second code is working but when I use with a defined name and use that defined name for data validation list its tells me that there is an error in the validation list source but when I use this function with index its returning the desired result.
Also some images to explain more:
I want to make a list from cells that contains a text and apply it here:
But without the number values.
The problem is that the resultant range is multiple columns and cannot be used as the source for a Data Validation List. If you cannot change the design of the table of options so that it is just one column, you need to find another way to set up the Validation List.
Here is a solution using VBA. I put this in a sub that can be run on demand as a macro, but you might drop it into a worksheet event that triggers when data on the sheet changes or some other event.
This will only create the validation list as far down as there is data in Column A. You'll probably want to carry it down further than this, or as mentioned, put this into a worksheet event so that it updates the Validation list as new rows are added.
I set up my sheets as follows, but you can also download my example here.
Option Explicit
Sub Create_Validation_List()
Dim rngList As Range, cl As Range
Dim rngValidationList As Range
Dim strList As String
Set rngList = Worksheets("BasicPrice").Range("A2:F3")
strList = ""
For Each cl In rngList
If Not IsNumeric(cl.Value) And Not cl.Value = "" Then strList = strList & "," & cl.Value 'Add to our Validation List
Next cl
strList = Mid(strList, 2) 'Chop off leading comma
'Apply Data Validation to this Range (starting at cell C2 and ending at the last row with data in column A)
Set rngValidationList = Range("C2:C" & Cells(Rows.Count, "A").End(xlUp).Row)
Application.EnableEvents = False
With rngValidationList.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=strList 'Pass in Validation List created above
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Application.EnableEvents = True
End Sub
Let me know if you have any questions.
I have a requirement to edit a column of data where each cell has to be edited to remove all non-numeric characters. The only data that I need are actual numbers and a decimal point if one was there originally. I found a piece of code that removes everything with the exception of a "%" character. If someone could look at the code below and let me know how to modify it I would be appreciative. Examples of the type of data I am editing are as follows Complete cell contents enclosed in quotes). "3" "2.5%" "17 nks" "3.00 %" "4 VNS"
Here's the code I have used;
Sub RemoveAlphas()
'' Remove alpha characters from a string.
Dim intI As Integer
Dim rngR As Range, rngRR As Range
Dim strNotNum As String, strTemp As String
Set rngRR = Selection.SpecialCells(xlCellTypeConstants, _
xlTextValues)
For Each rngR In rngRR
strTemp = ""
For intI = 1 To Len(rngR.Value)
If Mid(rngR.Value, intI, 1) Like "[0-9,.]" Then
strNotNum = Mid(rngR.Value, intI, 1)
Else: strNotNum = ""
End If
strTemp = strTemp & strNotNum
Next intI
rngR.Value = strTemp
Next rngR
End Sub
Thanks.
This can be done using Regex as shown below- Have tested with your exact sample data and works for me:
Sub RemoveAlphas()
'' Remove alpha characters from a string.
Dim intI As Integer
Dim rngR As Range, rngRR As Range
Dim strNotNum As String, strTemp As String
Dim RegEx As Object
Set rngRR = Selection.SpecialCells(xlCellTypeConstants, _
xlTextValues)
Set RegEx = CreateObject("VBScript.RegExp")
RegEx.Global = True
RegEx.Pattern = "[^\d.]+"
For Each rngR In rngRR
rngR.Value = RegEx.Replace(rngR.Value, "")
Next rngR
End Sub
If you are getting the results you need with the exception of a percent sign, you can insert into this part of your code a Replace function:
Next intI
strTemp = Replace(strTemp, "%", "") 'Remove the % sign and replace with nothing.
rngR.Value = strTemp
Next rngR
Try the RexExp below which builds on my code from Remove non-numeric characters from a range of cells, and uses variant arrays for speed.
The RegExp pattern is [^\d\.]+
Sub KillNonNumbers()
Dim rng1 As Range
Dim rngArea As Range
Dim lngRow As Long
Dim lngCol As Long
Dim lngCalc As Long
Dim objReg As Object
Dim X()
On Error Resume Next
Set rng1 = Selection.SpecialCells(xlCellTypeConstants, xlTextValues)
If rng1 Is Nothing Then Exit Sub
On Error GoTo 0
'See Patrick Matthews excellent article on using Regular Expressions with VBA
Set objReg = CreateObject("vbscript.regexp")
objReg.Pattern = "[^\d\.]+"
objReg.Global = True
'Speed up the code by turning off screenupdating and setting calculation to manual
'Disable any code events that may occur when writing to cells
With Application
lngCalc = .Calculation
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
'Test each area in the user selected range
'Non contiguous range areas are common when using SpecialCells to define specific cell types to work on
For Each rngArea In rng1.Areas
'The most common outcome is used for the True outcome to optimise code speed
If rngArea.Cells.Count > 1 Then
'If there is more than once cell then set the variant array to the dimensions of the range area
'Using Value2 provides a useful speed improvement over Value. On my testing it was 2% on blank cells, up to 10% on non-blanks
X = rngArea.Value2
For lngRow = 1 To rngArea.Rows.Count
For lngCol = 1 To rngArea.Columns.Count
'replace the leading zeroes
X(lngRow, lngCol) = objReg.Replace(X(lngRow, lngCol), vbNullString)
Next lngCol
Next lngRow
'Dump the updated array sans leading zeroes back over the initial range
rngArea.Value2 = X
Else
'caters for a single cell range area. No variant array required
rngArea.Value = objReg.Replace(rngArea.Value, vbNullString)
End If
Next rngArea
'cleanup the Application settings
With Application
.ScreenUpdating = True
.Calculation = lngCalc
.EnableEvents = True
End With
Set objReg = Nothing
End Sub
I want to be able to copy raw data into column A, hit run on the macro and it should remove any unwanted characters both before and after the data that I want to keep resulting in a cell just containing the data that I want. I also want it to go through all cells that are in the column, bearing in mind some cells may be empty.
The data that I want to keep is in this format: somedata0000 or somedata000
Sometimes the cell will contain 'rubbish' both before and after the data that I want to keep i.e. rubbishsomedata0000 or somedata0000rubbish or rubbishsomedata0000rubbish.
And also, sometimes a single cell will contain:
rubbishsomedata0000rubbish
rubbishsomedata0000rubbish
rubbishsomedata0000rubbish
This will need to be changed to:
NEW CELL: somedata0000
NEW CELL: somedata0000
NEW CELL: somedata0000
The 'somedata' text will not change but the 0000 (which could be any 4 numbers) will sometimes be any 3 numbers.
Also there may be some rows in the column that have no useful data; these should be removed/deleted from the sheet.
Finally, some cells will contain the perfect somedata0000, these should stay the same.
Sub Test()
Dim c As Range
For Each c In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
c = removeData(c.text)
Next
End Sub
Function removeData(ByVal txt As String) As String
Dim result As String
Dim allMatches As Object
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
RE.Pattern = "(somedata-\d{4}|\d{3})"
RE.Global = True
RE.IgnoreCase = True
Set allMatches = RE.Execute(text)
If allMatches.Count <> 0 Then
result = allMatches.Item(0).submatches.Item(0)
End If
ExtractSDI = result
End Function
I have put my code that I've got so far, all it does is go through each cell, if it matches it just removes the text that I want to keep as well as the stuff that I want removed! Why?
There are several issues in your code
As Gary said, you Function isn't returning a result
Your Regex.Pattern doesn't make sense
Your Sub doesn't attempt to handle multiple matches
Your Function doesn't even attempt to return multiple matches
Sub Test()
Dim rng As Range
Dim result As Variant
Dim i As Long
With ActiveSheet
Set rng = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
For i = rng.Rows.Count To 1 Step -1
result = removeData(rng.Cells(i, 1))
If IsArray(result) Then
If UBound(result) = 1 Then
rng.Cells(i, 1) = result(1)
Else
rng.Cells(i, 1).Offset(1, 0).Resize(UBound(result) - 1, 1).Insert xlShiftDown
rng.Cells(i, 1).Resize(UBound(result), 1) = Application.Transpose(result)
End If
Else
rng.Cells(i, 1).ClearContents
End If
Next
End Sub
Function removeData(ByVal txt As String) As Variant
Dim result As Variant
Dim allMatches As Object
Dim RE As Object
Dim i As Long
Set RE = CreateObject("vbscript.regexp")
RE.Pattern = "(somedata\d{3,4})"
RE.Global = True
RE.IgnoreCase = True
Set allMatches = RE.Execute(txt)
If allMatches.Count > 0 Then
ReDim result(1 To allMatches.Count)
For i = 0 To allMatches.Count - 1
result(i + 1) = allMatches.Item(i).Value
Next
End If
removeData = result
End Function