In excel 2010, how to do a validation if cell contain ',' then pop up a message to user ?
Please try to show your work ..
lets say Column A contains the data then below code work perfectly
this is what u wanted (TESTED)
Sub tested()
Dim erange As Range
Dim lrow As Integer
lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For Each erange In Range("A2:A" & lrow)
If InStr(erange.Value, ",") > 0 Then
MsgBox (erange.Address & " contains Comma ")
erange.Interior.Color = vbRed
End If
Next erange
End Sub
Using normal data validation, you could try this
=(LEN(A1) = LEN(SUBSTITUTE(A1,",","")))
If you want to avoid unnecessary loop use below code.
Sub findComma()
Dim srcRng As Range, findRng As Range
Dim firstCell As String
Dim lrow As Integer
lrow = Range("A" & Rows.Count).End(xlUp).Row
Set srcRng = Range("A1:A" & lrow)
Set findRng = srcRng.Find(What:=",", LookIn:=xlValues, LookAt:=xlPart)
If Not findRng Is Nothing Then firstCell = findRng.Address
Do Until findRng Is Nothing
MsgBox (findRng.Address & " contains Comma ")
findRng.Interior.Color = vbRed
Set findRng = srcRng.FindNext(findRng)
If findRng.Address = firstCell Then Exit Sub
Loop
End Sub
Related
I am trying to find any cells with just spaces in. When I run this though it finds cells that are blanks too. Is there anyway to just find cells with spaces?
For i = 1 to lastRow
If len(trim(this workbook.sheets("data").range("a" & i)) = 0 then
Msgbox("a" & i " contains only space")
End if
Next i
Plase, try:
Sub testFindSpaces()
Dim wsD as Worksheet, i As Long, x As String, lastRow As Long
Set wsD = ThisWorkbook.Sheets("data")
lastRow = wsD.Range("A" & wsD.rows.count).End(xlUp).row
For i = 1 To lastRow
x = wsD.Range("a" & i).Value
If UBound(Split(x, " ")) = Len(x) Then
MsgBox "a" & i & " contains only space"
End If
Next i
End Sub
Just exclude blanks by testing for Len(ThisWorkbook.Worksheets("data").Range("A" & i)) <> 0 too.
For i = 1 to lastRow
Dim Untrimmed As String
Untrimmed = ThisWorkbook.Worksheets("data").Range("A" & i).Value
If Len(Trim(Untrimmed) = 0 AND Len(Untrimmed) <> 0 then
Msgbox "a" & i & " contains only space"
End if
Next i
Alternativeley use ThisWorkbook.Worksheets("data").Range("A" & i).Value <> vbNullString to exclude blanks
For i = 1 to lastRow
Dim Untrimmed As String
Untrimmed = ThisWorkbook.Worksheets("data").Range("A" & i).Value
If Len(Trim(Untrimmed) = 0 AND Untrimmed <> vbNullString then
Msgbox "a" & i & " contains only space"
End if
Next i
Just to add alternatives:
With ThisWorkbook.Sheets("data").Range("A" & i)
If .Value Like "?*" And Not .Value Like "*[! ]*" Then
MsgBox ("A" & i & " contains only space")
End If
End With
You may also just create a new regex-object and use pattern ^ +$ to validate the input.
If you don't want to loop the entire range but beforehand would like to exclude the empty cells you could (depending on your data) use xlCellTypeConstants or the numeric equivalent 2 when you decide to use SpecialCells() method and loop the returned cells instead:
Dim rng As Range, cl As Range
Set rng = ThisWorkbook.Worksheets("Data").Range("A:A").SpecialCells(2)
For Each cl In rng
If Not cl.Value Like "*[! ]*" Then
MsgBox ("A" & cl.Row & " contains only spaces")
End If
Next cl
You may also no longer need to find your last used row, but note that this may error out if no data at all is found in column A.
A last option I just thought about is just some concatenation before validation:
For i = 1 To lastRow
If "|" & Trim(ThisWorkbook.Sheets("data").Range("A" & i).value & "|" = "| |" Then
MsgBox ("A" & i & " contains only space")
End If
Next
Macro to get a string of address of cells containing only space using Evaluate VBA function
Edited code below - As suggested by #VBasic2008 and #T.M. in the comments below.
Option Explicit
Sub Cells_with_Space_Only()
Dim ws As Worksheet
Set ws = Sheets("Sheet2")
'Macro to get a string of address of cells containing only space
'https://stackoverflow.com/questions/68891170/finding-cells-with-only-spaces
Dim rngArr, rngStr As String, i As Long, rng As Range
rngArr = Evaluate("IFERROR(ADDRESS((ISBLANK(" & ws.UsedRange.Address(External:=True) & _
")=FALSE)*(" & ws.UsedRange.Address(External:=True) & _
"=REPT("" "",LEN(" & ws.UsedRange.Address(External:=True) & _
")))*ROW(" & ws.UsedRange.Address(External:=True) & _
"),COLUMN(" & ws.UsedRange.Address(External:=True) & ")),""**"")")
rngStr = ""
'If number of columns in usedrange are less then loop with
'For i = 1 To ActiveSheet.UsedRange.Columns.Count
For i = 1 To ws.UsedRange.Rows.Count
'if looped with For i = 1 To ActiveSheet.UsedRange.Columns.Count
'rngStr = Join(Filter(Application.Transpose(Application.Index(rngArr, 0, i)) _
, "**", False, vbBinaryCompare), ",")
rngStr = Join(Filter(Application.Index(rngArr, i, 0) _
, "**", False, vbBinaryCompare), ",")
If rngStr <> "" Then
If rng Is Nothing Then
Set rng = Range(rngStr)
Else
Set rng = Union(rng, Range(rngStr))
End If
End If
Next i
Debug.Print rng.Address
End Sub
The macro returns a string for the sample data in the image below --
$D$1,$A$2,$F$2,$B$3,$E$4,$A$6,$F$6,$E$7,$B$8,$D$9,$C$10,$F$10,$A$11,$D$13,$F$13,$E$14,$A$16,$E$16,$D$17,$F$17:$F$18
Array formula in the worksheet -
=IFERROR(ADDRESS((ISBLANK($A$1:$F$18)=FALSE)*($A$1:$F$18=REPT(" ",LEN($A$1:$F$18)))*ROW($A$1:$F$18),COLUMN($A$1:$F$18)),"**")
Clear Solo Spaces
Couldn't think of any reason for doing this other than for clearing the cells containing only spaces.
Option Explicit
Sub ClearSoloSpaces()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Data")
Dim srg As Range ' Source Range
Set srg = ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))
Dim crg As Range ' Clear Range
Dim cCell As Range ' Current Cell in Source Range
Dim cString As String ' Current Cell's Value Converted to a String
For Each cCell In srg.Cells
cString = CStr(cCell.Value)
If Len(cString) > 0 Then
If Len(Trim(cString)) = 0 Then
If crg Is Nothing Then
Set crg = cCell
Else
Set crg = Union(crg, cCell)
End If
End If
End If
Next cCell
If crg Is Nothing Then
MsgBox "No cells containing only spaces found.", _
vbInformation, "Clear Solo Spaces"
Else
Dim Msg As Long
Msg = MsgBox("The cells in the rows '" _
& Replace(crg.Address, "$A$", "") _
& "' of column 'A' contain only spaces." & vbLf _
& "Do you want to clear them?", _
vbInformation + vbYesNo, "Clear Solo Spaces")
If Msg = vbYes Then
crg.Clear ' or crg.ClearContents ' to preserve formatting
End If
End If
End Sub
Just for the sake of showing alternatives (#T.M.), please test the next one, too:
Private Sub testFindSpacesBis()
Dim wsD As Worksheet, i As Long, x As String, lastRow As Long
Set wsD = ActiveSheet ' ThisWorkbook.Sheets("data")
lastRow = wsD.Range("A" & wsD.rows.count).End(xlUp).row
For i = 1 To lastRow
x = wsD.Range("a" & i).Value
If StrComp(x, space(Len(x)), vbBinaryCompare) = 0 Then
MsgBox "a" & i & " contains only spaces"
End If
Next i
End Sub
I adapted code I found online.
It finds the string "car" in column A and returns the rows as an array
It assigns a variable to the length of the array (how many matches it found)
It assigns a variable to generate a random number between 0 and the length of the array
It then prints a random matching row's value into K3
Dim myArray() As Variant
Dim x As Long, y As Long
Dim msg As String
With ActiveSheet.Range("A1:A" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row)
Set c = .find("Car", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
ReDim Preserve myArray(y)
myArray(y) = c.Row
y = y + 1
Set c = .findNext(c)
If c Is Nothing Then
GoTo DoneFinding
End If
Loop While c.Address <> firstAddress
End If
DoneFinding:
End With
For x = LBound(myArray) To UBound(myArray)
msg = msg & myArray(x) & " "
Next x
ArrayLen = UBound(myArray) - LBound(myArray)
random_index = WorksheetFunction.RandBetween(0, ArrayLen)
MsgBox myArray(random_index)
Dim test As String
test = "B" & myArray(random_index)
Range("K3").Value = Range(test)
Example
I'm struggling with adapting the find code to allow for multiple criteria. So in my example, it finds "Car". What if I want to find matches that had "Car" in column A and "Red" in column D?
I tried
With ActiveSheet.Range("A1:A" & "D1:D" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row & ActiveSheet.Range("D" & Rows.Count).End(xlUp).Row)
Set c = .find("Car", "Red", LookIn:=xlValues)
I get type mismatch on the Set line.
In case it is confusing, it currently looks for a string e.g. "Car" but I will eventually link this to the variable which will be assigned to a data validation list. So if the user chooses "car" from a drop down list, this is what it will search for.
Maybe Advancde Filter is something that fit your needs:
Example Code
Option Explicit
Public Sub FilterData()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("YourSheetName")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim CriteriaRange As Range
Set CriteriaRange = ws.Range("A1", "E2")
Dim DataRange As Range
Set DataRange = ws.Range("A4", "E" & LastRow)
DataRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=CriteriaRange, Unique:=False
End Sub
Public Sub ShowAll()
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End Sub
Edit according comment:
You can use the advanced filter and then loop through the filter results:
Option Explicit
Public CurrentRow As Long
Public Sub FilterData()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("YourSheetName")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim CriteriaRange As Range
Set CriteriaRange = ws.Range("A1", "E2")
Dim DataRange As Range
Set DataRange = ws.Range("A4", "E" & LastRow)
DataRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=CriteriaRange, Unique:=False
End Sub
Public Sub ShowAll()
On Error Resume Next
ActiveSheet.ShowAllData
CurrentRow = 1
On Error GoTo 0
End Sub
Public Sub GetNextResult()
FilterData
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("YourSheetName")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim DataRange As Range
Set DataRange = ws.Range("A4", "E" & LastRow)
Dim FilteredData As Range
Set FilteredData = DataRange.Resize(ColumnSize:=1).SpecialCells(xlCellTypeVisible)
If CurrentRow + 1 > FilteredData.Cells.Count Then
CurrentRow = 1
End If
CurrentRow = CurrentRow + 1
Dim i As Long
Dim Cell As Variant
For Each Cell In FilteredData
i = i + 1
If i = CurrentRow Then
Cell.EntireRow.Select
'or
'MsgBox Cell.Value & vbCrLf & Cell.Offset(0, 1) & vbCrLf & Cell.Offset(0, 2) & vbCrLf & Cell.Offset(0, 3) & vbCrLf & Cell.Offset(0, 4)
End If
Next Cell
End Sub
I am tring to alter this code FindReplace_With_Offset_1 to FindReplace_With_Offset_2
FindReplace_With_Offset_1 Run on a Col Range and it works fine
I need FindReplace_With_Offset_2 to run only on each Cell in the Col Range i.e. I need each cell to be its own range, when I run it I get #NAME? for every Cell with value #N/A
Thanks
Sub FindReplace_With_Offset_1()
Dim wsFR As Worksheet, wsT As Worksheet
Dim tLR As Long, i As Long
Set wsT = ThisWorkbook.Worksheets("XXX")
Set wsFR = ThisWorkbook.Worksheets("ZZZ")
With wsT
tLR = .Range("C" & .Rows.Count).End(xlUp).Row
With .Range("B2:B" & tLR) 'The Offset Range
.Value = _
"=VLOOKUP(D2," & wsFR.Range("D1").CurrentRegion.Address(1, 1, , 1) & ",2,0)"
.Value = .Value
End With
End With
End Sub
Code2
Sub FindReplace_With_Offset_2()
Dim wsFR As Worksheet, wsT As Worksheet
Dim Rng As Range, aCell As Range
Dim tLR As Long, i As Long
Set wsT = ThisWorkbook.Worksheets("XXX")
Set wsFR = ThisWorkbook.Worksheets("ZZZ")
With wsT
tLR = .Range("C" & .Rows.Count).End(xlUp).Row
Set Rng = .Range("A2:A" & tLR)
For Each aCell In Rng
If aCell.text = "#N/A" Then
aCell.Value = _
"=VLOOKUP(aCell," & wsFR.Range("C1").CurrentRegion.Address(1, 1, , 1) & ",2,0)"
aCell.Value = aCell.Value
Else
aCell = aCell
End If
Next aCell
End With
End Sub
Maybe it's because you're trying to put the code to read a error value, and for the excel the cell value isn't the text "#N/A", try to use the IfError formula to run the verification on the desired cell, like this:
If WorksheetFunction.IfError(aCell,"Error") = "Error" Then
i have created the following code, it aims at delete the empty cell in column R that exists between data, the problem comes to how to store the blank cell in range, any advise?
Sub Macro1()
Dim lastRow_1 As Long
Dim counter_1 As Long
Dim rng_1 As Range, aCell As Range
lastRow_1 = Range("R" & Rows.Count).End(xlUp).Row
MsgBox lastRow_1
counter_1 = 1
For counter_1 = 1 To lastRow_1
If Trim(Range("R" & counter_1).Value) = "" Then
Set aCell = Range("R" & counter_1)
rng_1 = Union(rng_1, aCell)
End If
Next
rng_1.Delete xlUp
End Sub
Assuming R200 is the last cell in the range
range("R1:R200").SpecialCells(xlCellTypeBlanks).Delete
I am new in VBA and I am trying to solve one problem. I have Only Items column in Excel data like below. And I want to add code for each item which is in Code column.
Code Items
Animals:
AN Cow
AN Dog
AN Zeebra
AN Deer
Flower:
FL Rose
FL Sunflower
Fruit:
FR Mango
FR Banana
FR Pineapple
FR Cherry
I used following Loop for that
For Each Cell In Sheets("Sheet1").Range("B" & Sheets("Sheet1").Columns("B:B").Cells.Find(what:="Animal:", searchdirection:=xlPrevious).Offset(1, 0).Row & ":B" & Sheets("Sheet1").Range("B").End(xlDown).Row)
If Cell.Value <> "Flower:" Then
Cell.Offset(1, 0).Select
Cell.Offset(0, -1).Value = "AN"
ElseIf Cell.Value = "Flower:" Then
Range(Selection, Selection.End(xlDown)).Select
Cell.Offset(0, -1).Value = "FL"
End If
Next Cell
But, this is not acheiving what I need. can please someone let me know what to do in this case?
This code uses a different approach (do while) but achieves what you want. It identifies the category by looking for a colon : within the cell. It then sets the code and applies it to the offset(0,-1) until a new code is found.
Sub FillOffset()
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
Dim i As Long
i = 2
Dim cell As Range
Do Until i > ws.Range("B" & Rows.Count).End(xlUp).Row
If InStr(1, ws.Range("B" & i).Text, ":", vbTextCompare) Then
Dim code As String
code = UCase(Left(ws.Range("B" & i).Text, 2))
Else
ws.Range("B" & i).Offset(0, -1) = code
End If
i = i + 1
Loop
End Sub
Sample output:
#mehow beat me by a a few seconds, but this code will also solve your problem.
Sub AddCodeForItems()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim lastRow As Long
Dim code As String
Set ws = ThisWorkbook.ActiveSheet
lastRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("B2:B" & lastRow)
For Each cell In rng
If Right(Trim(cell.Value), 1) = ":" Then
code = UCase(Left(Trim(cell.Value), 2))
Else
cell.Offset(, -1).Value = code
End If
Next cell
End Sub
Slightly different approach:
Sub tgr()
Dim rngFound As Range
Dim rngLast As Range
Dim strFirst As String
With ActiveSheet.Columns("B")
Set rngFound = .Find(":", .Cells(.Cells.Count), xlValues, xlPart)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
Set rngLast = Range(rngFound.Offset(1), .Cells(.Cells.Count)).Find(":", , xlValues, xlPart)
If rngLast Is Nothing Then Set rngLast = .Cells(.Cells.Count).End(xlUp).Offset(1)
Range(rngFound.Offset(1, -1), rngLast.Offset(-1, -1)).Value = UCase(Left(rngFound.Text, 2))
Set rngFound = Columns("B").Find(":", rngFound, xlValues, xlPart)
Loop While rngFound.Address <> strFirst
End If
End With
Set rngFound = Nothing
Set rngLast = Nothing
End Sub