Finding Cells With Only Spaces - excel

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

Related

Count (Not list!) unique items in a range to assign to a variable

I need a count of unique items from a range to know how many lines to add to make room for a pivot table. Being that I know excel better then VBA I put together the following code:
With ActiveSheet
LR = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Range("F" & LR).Formula2R1C1 = "=UNIQUE(R3C:R[-1]C)"
With ActiveSheet
CT = .Cells(.Rows.Count, "F").End(xlUp).Row
End With
Range("F" & LR).ClearContents
R = "1:" & CT - LR + 3
Rows(R).Insert Shift:=xlDown
I would like to know how I can have VBA do the calulations on its own so I can avoid adding and deleting formulas from the sheet.
You can count Unique in VBA by adding to a collection or taken your post as an example by using the UNIQUE function in combination with evaluate:
With ActiveSheet
LR = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
x = UBound(Application.Evaluate("UNIQUE(F3:F" & LR & ")"))
Count Unique (Dictionary)
If you don't have 365 i.e. you don't have UNIQUE you can use the following function.
The Function and OP's Test
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the number of unique values in a range.
' Remarks: Error and empty values are excluded.
' The range can be non-contiguous.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function countUnique(SourceRange As Range) _
As Long
' Initialize error handling.
Const ProcName As String = "countUnique"
On Error GoTo clearError ' Turn on error trapping.
' Check Source Range.
If SourceRange Is Nothing Then
GoTo ProcExit
End If
' Write values from Source Range to arrays of Data Array ('Data').
Dim AreasCount As Long
AreasCount = SourceRange.Areas.Count
Dim Help As Variant
ReDim Help(1 To 1, 1 To 1)
Dim Data As Variant
ReDim Data(1 To AreasCount)
Dim rng As Range
Dim n As Long
For Each rng In SourceRange.Areas
n = n + 1
If rng.Rows.Count > 1 Or rng.Columns.Count > 1 Then
Data(n) = rng.Value
Else
Data(n) = Help
Data(1, 1) = rng.Value
End If
Next rng
' Write (unique) values from arrays of Data Array to a Dictionary ('dict').
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim CurrentValue As Variant
Dim i As Long
Dim j As Long
For n = 1 To AreasCount
For i = 1 To UBound(Data(n), 1)
For j = 1 To UBound(Data(n), 2)
CurrentValue = Data(n)(i, j)
If Not IsError(CurrentValue) And Not IsEmpty(CurrentValue) Then
dict(CurrentValue) = Empty
End If
Next j
Next i
Next n
' Write result (number of elements in the Dictionary).
countUnique = dict.Count
ProcExit:
Exit Function
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Function
Sub testOP()
Dim LR As Long ' Last Row
Dim UC As Long ' Unique Count
With ActiveSheet
LR = .Cells(.Rows.Count, "A").End(xlUp).Row
UC = countUnique(.Range(.Cells(3, "F"), .Cells(LR, "F")))
Debug.Print UC
End With
End Sub
Non-Contiguous Test
' Select a range. Then press CTRL and select another range, etc.
' Then run the following procedure.
Sub testNonContiguous()
Dim rng As Range
If TypeName(Selection) = "Range" Then
Set rng = Selection
MsgBox "Range '" & rng.Address(0, 0) & "' contains " _
& countUnique(rng) & " unique item(s)."
End If
End Sub
Performance Tests
' Copy the following formula to A1 and copy down to the bottom of the worksheet.
' =RANDBETWEEN(1,1000000)
' Select the whole column and do a 'Copy/Paste Values'.
' Running this test took about 21 seconds on my machine.
Sub testCountUnique()
Dim rng As Range
Set rng = Range("A:A")
Debug.Print "Range '" & rng.Address(0, 0) & "' contains " _
& countUnique(rng) & " unique item(s)."
End Sub
' This is the same test using UNIQUE which I don't have. I would appreciate
' the feedback, if someone could measure the time this takes to finish.
Sub testUnique()
Dim rng As Range
Set rng = Range("A:A")
Debug.Print "Range '" & rng.Address(0, 0) & "' contains " _
& UBound(Application.Evaluate("UNIQUE(" _
& rng.Address(0, 0) & ")")) & " unique item(s)."
End Sub
You can try so:
Function getCountUnique(rSource As Range) As Long
With Application.WorksheetFunction
getCountUnique = .Count(.Unique(rSource, False, False))
End With
End Function
Call it from your subroutine like as:
With ActiveSheet
LR = ActiveSheet.Cells(.Rows.Count, "A").End(xlUp).Row
uniCount = getCountUnique(.Range("A3:A" & LR))
End With

Selecting a Excel sheet based on number

I'm new to macros and VBA in Excel. Is there a way to check if the Testvalue is between Value 1 and Value 2, and move to the corresponding sheet? And if it's not, move to the next row and repeat.
E.g.
With the testvalue 3742 sheet A21 should be selected.
Simply iterate over each row until required condition is met:
Dim testVal As Long, r As Integer
Dim yourSheet As Worksheet
Set yourSheet = Sheet1
With yourSheet
testVal = .Range("E2").Value
r = 2
Do Until (.Range("A" & r).Value <= testVal) And _
(.Range("B" & r).Value >= testVal)
ThisWorkbook.Worksheets(.Range("C" & r).Value).Activate
r = r + 1
Loop
End With
In my opinion, instead of looping each row is faster if you use Find method.
Sub test()
Dim rngSearchA As Range, rngSearchB As Range, rngFoundA As Range, rngFoundB As Range
Dim strValue As String, strSheetName As String
Dim LastRowA As Long, LastRowB As Long
With ThisWorkbook.Worksheets("Sheet1")
strValue = .Range("E2").Value
strSheetName = ""
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
LastRowB = .Cells(.Rows.Count, "B").End(xlUp).Row
Set rngSearchA = .Range("A2:A" & LastRowA)
Set rngSearchB = .Range("B2:B" & LastRowB)
Set rngFoundA = rngSearchA.Find(strValue, LookIn:=xlValues, Lookat:=xlWhole)
Set rngFoundB = rngSearchB.Find(strValue, LookIn:=xlValues, Lookat:=xlWhole)
If Not rngFoundA Is Nothing And Not rngFoundB Is Nothing Then
If .Range("C" & rngFoundA.Row).Value <> .Range("C" & rngFoundB.Row).Value Then
MsgBox "Searching value appears in both columns with different Sheet name."
Else
strSheetName = .Range("C" & rngFoundA.Row).Value
End If
ElseIf Not rngFoundA Is Nothing Or Not rngFoundB Is Nothing Then
If Not rngFoundA Is Nothing Then
strSheetName = .Range("C" & rngFoundA.Row).Value
Else
strSheetName = .Range("C" & rngFoundB.Row).Value
End If
Else
MsgBox "Value not found!"
End If
If strSheetName <> "" Then
ThisWorkbook.Worksheets(strSheetName).Activate
End If
End With
End Sub

How to apply multiple criteria to .Find?

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

Select the rows (A:J) if column E contains more than 4 Cells with value. Next selective print the selected Rows. repeat process till last value

Select the rows (A:J) if column E contains more than 4 Cells with value. Next is to selective print the selected Rows. Then it need to repeat the process until the last filled cell. Have been searching for a macro to get tenter link description herehis done for weeks but sadly to no avail.
Hope you all can assist me on this.
After being select as such i believe i could just proceed with printing under "printing selection" setting
This is one of the printed result of the 2 selected row
Added code from comments
Sub EnquiryPrep()
Dim x As Integer
Dim rng As Range
With ActiveSheet
LR = .Range("a" & Rows.Count).End(xlUp).Row
For Each cell In .Range("e7:e" & LR)
If cell.Value <> "" Then
If rng Is Nothing Then
Set rng = cell.Offset(, -4).Resize(, 10)
Else
Set rng = Union(rng, cell.Offset(, -4).Resize(, 10))
End If
End If
Next cell
rng.Select
End With
End Sub
Put this into your ThisWorkbook Code
WHAT IS OUTPUT FROM DEBUG.PRINT statments?? Cut/Paste from Immediate
window below code
Try:
Sub PrintValidRows()
Const SHEET_NUM As Integer = 1 ' Which Sheet to Use
Const CHECK_COL As Integer = 5 ' Column E
Const START_ROW As Integer = 8
Const MIN_FILLED As Integer = 5 ' Min number required for print
Const LAST_COL As String = "H" ' Last column to print
Dim lastCellBlank As Boolean
Dim lngRow As Long
Dim lngLastRow As Long
Dim lngStartRow As Long
Dim intNumFilled As Integer
Dim strRange As String
Dim strPrintRange As String
Dim ws As Worksheet
Set ws = Sheets(SHEET_NUM)
ws.Activate
ws.Cells(1, 1).Select
intNumFilled = 0
' Get last row of data
lngLastRow = ActiveCell.SpecialCells(xlLastCell).Row
Debug.Print "Last Row: "; lngLastRow
lngStartRow = START_ROW
For lngRow = START_ROW To lngLastRow
If IsEmpty(Cells(lngRow, CHECK_COL)) Then
If intNumFilled >= MIN_FILLED Then
strRange = "A" & lngStartRow & ":" & LAST_COL & lngRow - 1
Debug.Print "Adding Range: " & strRange
If lngStartRow = START_ROW Then ' first range
strPrintRange = strRange
Else
strPrintRange = strPrintRange & "," & strRange
End If
End If
' Reset Filled Cell Counter
intNumFilled = 0
' Reset StartRow to next row
lngStartRow = lngRow + 1
Else
intNumFilled = intNumFilled + 1
End If
Next lngRow
' Check for last set of data
If intNumFilled >= MIN_FILLED Then
strRange = "A" & lngStartRow & ":" & LAST_COL & lngRow - 1
Debug.Print "Adding Range: " & strRange
If lngStartRow = START_ROW Then ' first range
strPrintRange = strRange
Else
strPrintRange = strPrintRange & "," & strRange
End If
End If
' Show Print Range in Immediate Window
Debug.Print "Print Range: " & strPrintRange
If strPrintRange <> "" Then
Range(strPrintRange).Select
End If
' You can record a macro to get it to printout exactly what how want
' REMOVE THIS TO TEST HIGHLIGHTING
'Application.Selection.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
End Sub

Input box to paste found rows to new sheet

I have what is working code but I want to be able to run it 2,3, 4 times and have it just keep moving down the destination sheet. Instead it overwrites what the last pass pasted.
Sub Comparison_Entry()
Dim myWord$
myWord = InputBox("Enter UID, If no more UIDs, enter nothing and click OK", "Enter User")
If myWord = "" Then Exit Sub
Application.ScreenUpdating = False
Dim xRow&, NextRow&, LastRow&
NextRow = 1
LastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For xRow = 1 To LastRow
If WorksheetFunction.CountIf(Rows(xRow), "*" & myWord & "*") > 0 Then
Rows(xRow).Copy Sheets("Sheet1").Rows(NextRow)
NextRow = NextRow + 1
End If
Next xRow
Application.ScreenUpdating = True
MsgBox "Copyng complete, " & NextRow - 2 & " rows containing" & vbCrLf & _
"''" & myWord & "''" & " were copied to Sheet1.", 64, "Done"
End Sub``
I tried adding a loop to this but each pass through it would start over at the top of Sheet1. Similarly, if I simply call the Sub again I get the same result.
Normally you would know what column to search through, such as what column is UID. in this example code I will assume it is column A of the active sheet, change the column letter to what suites you.
Sub Comparison_EntryB()
Dim Rws As Long, rng As Range, c As Range
Dim ws As Worksheet, sh As Worksheet, s As String
Set ws = ActiveSheet
Set sh = Sheets("Sheet1")
With ws
Rws = .Cells(.Rows.Count, "A").End(xlUp).Row 'change to column you need you search through
Set rng = .Range(.Cells(1, "A"), .Cells(Rws, "A")) 'change to column you need to search through
End With
s = InputBox("enter Something")
For Each c In rng.Cells
If UCase(c) Like "*" & UCase(s) & "*" Then
c.EntireRow.Copy sh.Cells(sh.Rows.Count, "A").End(xlUp).Offset(1)
End If
Next c
End Sub

Resources