This question already has answers here:
Detect if range is empty
(8 answers)
Closed 2 years ago.
Is there any way to shorten down this line with a better range statement? When one cell out of the range ("C3:I3") is empty I need it to produce a MsgBox, else run the rest of the code.
If IsEmpty(Range("C3")) = True Or IsEmpty(Range("D3")) = True Or IsEmpty(Range("E3")) = True Or IsEmpty(Range("F3")) = True Or IsEmpty(Range("G3")) = True Or IsEmpty(Range("H3")) = True Or IsEmpty(Range("I3")) = True Then
When I use If IsEmpty(Range("C3:I3")) = True Then the code behaves differently and does not work when only one cell is empty.
Try this:
Function IsRangeEmpty(ByRef theRange As Range) As Boolean
Dim c As Range
For Each c In theRange
If Not IsEmpty(c) Then
IsRangeEmpty = False
Exit Function
End If
Next c
IsRangeEmpty = True
End Function
You could any of the below:
Loop range:
Sub test()
Dim rng As Range, cell As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .Range("C3:C13")
For Each cell In rng
If cell = "" Then
MsgBox "Empty cell!"
End If
Next
End With
End Sub
Pass the range to an array and loop array - Faster:
Sub test_1()
Dim arr As Variant
Dim i As Long
With ThisWorkbook.Worksheets("Sheet1")
arr = .Range("C3:C13")
For i = LBound(arr) To UBound(arr)
If arr(i, 1) = "" Then
MsgBox "Empty cell!"
End If
Next
End With
End Sub
Related
I have a file called tg. I'd like to loop through the column A and everytime I come across an uppercase bold value, I'd like to store it as a key of my dictionary pp. The item associated is a collection of all the values up until the next uppercase and bold value. And repeat. My code doesn't seem to produce anything. Any help would be appreciated.
EDIT: I tested the my code with:
MsgBox (Pairs.Items(0).Count) and I get 0.
Function Pairs() As Dictionary
Call Files
With tg
Dim rng As Range
Dim pp As New Dictionary
Dim item As Variant
Dim arr
Dim gp As Variant
Set arr = New Collection
For Each rng In .Range("A1:A50")
If Not IsEmpty(rng) And IsUpper(rng.Value) And rng.Value <> "NULL" And rng.Font.Bold = True Then
gp = rng.Value
Do While Not IsEmpty(rng) And Not IsUpper(rng.Value) And rng.Font.Bold = True '
arr.Add rng.Value
Loop
pp.Add gp, arr
End If
Next rng
Set Pairs = pp
End With
End Function
Please, use the next faster way. It find the first Bolded cell, checks if isUpper and place in a dictionary (as key) the matched such cells value and the range in between as item:
Function Pairs() As Scripting.Dictionary
Dim tg As Worksheet, rng As Range, cB As Range, firstAddress As String, pp As New Scripting.Dictionary
Set tg = ActiveSheet 'use here the sheet you need
Set rng = tg.Range("A1:A50")
With Application.FindFormat
.Clear
.Font.Bold = True
End With
Set cB = rng.Find(what:=vbNullString, Searchformat:=True)
Dim prevRow As Long, prevKey As String
If Not cB Is Nothing Then
If IsUpper(cB.value) Then
firstAddress = cB.Address:
Do
If prevRow <> 0 Then Set pp(prevKey) = tg.Range("A" & prevRow & ":A" & cB.row - 1)
pp.Add cB.value, 1: prevRow = cB.row: prevKey = cB.value
Do
Set cB = rng.Find(what:=vbNullString, After:=cB, Searchformat:=True)
Loop Until IsUpper(cB.value)
Loop While cB.Address <> firstAddress
End If
Set pp(prevKey) = tg.Range("A" & prevRow & ":A50")
Else
MsgBox "No bolded cell in Uppercase has been found..."
End If
Set Pairs = pp
End Function
Function IsUpper(s) As Boolean
With CreateObject("VBScript.RegExp")
.Pattern = "^[^a-z]*$"
IsUpper = .test(s)
End With
End Function
It can be tested with something like:
Sub testPairs()
Dim i As Long, pp As Scripting.Dictionary
Set pp = Pairs
If pp.count = 0 Then Exit Sub
For i = 0 To pp.count - 1
Debug.Print pp.Keys()(i), pp.Items()(i).Address
Debug.Print Join(Application.Transpose(pp.Items()(i).value), "|")
Next i
End Sub
For the last occurrence it uses the range starting below it and the last cell in the range. If you will not use something static ("A1:A50"), the calculated last cell can be used...
If you need/want a collection instead of range as a dictionary item, it can be done, but in the way I tried handling the processing the range looks the most appropriate. You can easily place the range in an array and do whatever you need with it...
Please, send some feedback after testing it.
Your loop starting with Do While Not IsEmpty(rng) needs an incrementation, otherwise will exit immediately in case of a match but will stay in a continuous loop if not...
If you like more your way, or want better understanding where the mistake is, please replace this part:
Do While Not IsEmpty(rng) And Not IsUpper(rng.Value) And rng.Font.Bold = True '
arr.Add rng.Value
Loop
Firstly a new variable should be declared `Dim i As Long`.
Then replace with:
Do
arr.Add rng.Offset(i).value
i = i + 1
Loop Until IsUpper(rng.Offset(i).value) And rng.Offset(i).Font.Bold = True Or rng.Offset(i).value = ""
i = 0
Do is not oK use If, and a problem in For.
For Each rng In .Range("A1:A50").Cells
I would like ask what's the reason to appear an error when I want return the value of my function
Public Function Alphabet_SEF() As Integer
Dim AllAreAlphabetic As Boolean
Dim ReturnVal As Integer
AllAreAlphabetic = True
Sheets("BlaBla").Activate
For i = 1 To Sheets("BlaBla").Range("E1", Range("E1").End(xlDown)).Rows.Count
If (VarType(Range("E1")) <> 8) Then
AllAreAlphabetic = False
Exit For
End If
Next
Sheets("CdM").Activate
If (AllAreAlphabetic) Then
ReturnVal = 1
Else
ReturnVal = 0
End If
Alphabet_SEF = ReturnVal
End Function
When I put in my exel book "=Alphabet_SEF()" appear #value!
Try this - it does not rely on BlaBla being active
Public Function Alphabet_SEF() As Boolean
Dim rng As Range, c As Range
Application.Volatile 'forces recalculation: use when you have no parameters for
' Excel to use to determine when it needs to be recalculated
With Sheets("BlaBla")
Set rng = .Range(.Range("E1"), .Cells(.Rows.Count, "E").End(xlUp))
End With
For Each c In rng.Cells
If VarType(c) <> 8 Then
Alphabet_SEF = False 'set to false and exit function
Exit Function
End If
Next
Alphabet_SEF = True 'if got here then all values are type 8
End Function
I would like to make a shorter code for multiple elseif statements
My code looks like this:
Sub geography()
Worksheets("Social").Rows("3:165").Hidden = True
Dim cell As Range
For Each cell In Range("F3:F165")
If cell.Value = "GIS" Then
Rows(cell.Row).EntireRow.Hidden = False
ElseIf cell.Value = "CLIMATE" Then
Rows(cell.Row).EntireRow.Hidden = False
ElseIf cell.Value = "TRAVEL" Then
Rows(cell.Row).EntireRow.Hidden = False
ElseIf cell.Value = "TOURISM" Then
Rows(cell.Row).EntireRow.Hidden = False
ElseIf cell.Value = "WILDLIFE" Then
Rows(cell.Row).EntireRow.Hidden = False
End If
Next
End Sub
I found some similar thread here:
Eliminating multiple Elseif statements
but it applies to the range instead of the boolean, like in my case.
Regardless I built the code, based on my situation:
Sub geography2()
Dim arr, res
Dim cell As Range
Dim Variable As Boolean
arr = Array(Array("GIS", False), _
Array("CLIMATE", False), _
Array("TRAVEL", False), _
Array("TOURISM", False), _
Array("WILDLIFE", False))
res = Rows(cell.Row).EntireRow.Hidden
If Not IsError(res) Then
Variable = res
End If
End Sub
but it doesn't work, as the debugger points the line:
res = Rows(cell.Row).EntireRow.Hidden
and says:
Object variable or with block variable not set
How can I cut down the bulk elseif statement then?
Hide Rows (Match / Select Case)
The Select Case version is case-sensitive while the Application.Match version is not.
The Code
Option Explicit
Sub geographyMatch()
Const RowNumbers As String = "3:165"
Dim Criteria As Variant
Criteria = Array("GIS", "CLIMATE", "TRAVEL", "TOURISM", "WILDLIFE")
Worksheets("Social").Rows(RowNumbers).EntireRow.Hidden = True
Dim rng As Range
Dim cel As Range
For Each cel In Worksheets("Social").Columns("F").Rows(RowNumbers)
If Not IsError(Application.Match(cel.Value, Criteria, 0)) Then
If Not rng Is Nothing Then
Set rng = Union(rng, cel)
Else
Set rng = cel
End If
End If
Next cel
If Not rng Is Nothing Then
rng.EntireRow.Hidden = False
End If
End Sub
Sub geographySelectCase()
Const RowNumbers As String = "3:165"
Worksheets("Social").Rows(RowNumbers).EntireRow.Hidden = True
Dim rng As Range
Dim cel As Range
For Each cel In Worksheets("Social").Columns("F").Rows(RowNumbers)
Select Case cel.Value
Case "GIS", "CLIMATE", "TRAVEL", "TOURISM", "WILDLIFE"
If Not rng Is Nothing Then
Set rng = Union(rng, cel)
Else
Set rng = cel
End If
End Select
Next cel
If Not rng Is Nothing Then
rng.EntireRow.Hidden = False
End If
End Sub
To eliminate multiple elseifs, or arrays, try combining if statements with regular expression
Make sure you enable regular expression on: Tools > References > checkbox: "Microsoft VBScript Regular Expressions 5.5"
The function will look for the strings you mentioned ("GIS|CLIMATE|TRAVEL|TOURISM|WILDLIFE") and return True if it passes the regex test, it unhides the cell
Please let me know if it works, if not lets try solving it!
Thanks,
Option Explicit
Dim wb As Workbook
Dim cel As Range
Dim sRng As Range
Dim regex As New RegExp
Sub foo()
Set wb = ThisWorkbook
Set sRng = wb.Sheets("Social").Range("F3:F165")
wb.Sheets("Social").Rows("3:165").Hidden = True
For Each cel In sRng
If chkexist(cel.Value, "GIS|CLIMATE|TRAVEL|TOURISM|WILDLIFE") = True Then
cel.EntireRow.Hidden = False
Else
End If
Next cel
End Sub
Private Function chkexist(ByRef chkstr As String, ByVal patstr As String) As Boolean
'function that tests str if contains regex pattern
'returns boolean
With regex
.Global = True
.Pattern = patstr
End With
chkexist = regex.Test(chkstr)
End Function
Is there any quicker method than using a for loop to find the first instance of a formula in a cell?
For Each dc In .Worksheets("testWS").Range(searchRange)
If dc.hasFormula() = True Then
formulaRow = Split(dc.Address, "$")(2)
formula = dc.formula
Exit For
End If
Next
No loop needed - use Range.SpecialCells. Include error handling since there may be no cells with formulas.
On Error Resume Next
Dim formulaRng As Range
Set formulaRng = .Worksheets("testWS").Range(searchRange).SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not formulaRng Is Nothing Then
Debug.Print formulaRng.Cells(1).Row
Debug.Print formulaRng.Cells(1).Formula
End If
Function FindFirstFormulaRow(ByRef rng As Range) As Long
Dim arrFormulas As Variant
Set arrFormulas = rng.SpecialCells(xlCellTypeFormulas)
Set rng = arrFormulas
If Not rng Is Nothing Then
FindFirstFormulaRow = Split(rng.Cells(1).Address, "$")(2)
Set rng = rng.Cells(1)
End If
End Function`
I'm trying to create a vba script that will search for the _ in all the cells fallen under Crude Items column. However, when it finds one, it will split the values from _ and place the rest in corresponding cells fallen under Refined Ones column.
I've tried with the following which is doing the job flawlessly but I wish to search and replace the values using column headers:
Sub CopyAndReplace()
Dim cel As Range
For Each cel In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).row)
If cel.value <> "" Then
Sheets("Sheet1").Range(cel(1, 3).Address) = Split(cel, "_")(1)
End If
Next cel
End Sub
To let you visualize how the sheet might look like:
How can I search and replace the values using column headers?
I am not sure this is what you are after, but a few important mentions...
Try to always use at least a worksheet qualifier when writing your code. How else is your program going to know explicitly where you would like it to operate?
I have changed your process slightly, but again, not sure if this is exactly what you are after. See below code.
Sub SplitByHeader()
Dim i As Long
Dim crudeHeader As Range, refinedHeader As Range
Dim ws As Worksheet
'set ws
Set ws = ThisWorkbook.Sheets("Sheet1")
'set header ranges
Set crudeHeader = ws.Rows(1).Find(What:="Crude Items", LookAt:=xlWhole)
Set refinedHeader = ws.Rows(1).Find(What:="Refined Ones", LookAt:=xlWhole)
'simple error handler
If crudeHeader Is Nothing Or refinedHeader Is Nothing Then Exit Sub
For i = 2 To ws.Cells(ws.Rows.Count, crudeHeader.Column).End(xlUp).Row
If ws.Cells(i, crudeHeader.Column).Value <> "" Then
ws.Cells(i, refinedHeader.Column).Value = Split(ws.Cells(i, crudeHeader.Column).Value, "_")(1)
End If
Next i
End Sub
I have just tried this one with the code below:
It is a good idea to add additional check to the condition, like this - If myCell.Value <> "" And InStr(1, myCell, "_") Then to avoid starting from A2.
The idea is that the LocateValueCol locates the column of the first row, which has the string, passed to it. Knowing this, it works ok.
Option Explicit
Sub CopyAndReplace()
Dim searchColumn As Long
searchColumn = LocateValueCol("SearchCol", Worksheets(1))
Dim replaceColumn As Long
replaceColumn = LocateValueCol("ReplaceCol", Worksheets(1))
Dim myCell As Range
Dim lastCell As Long
With Worksheets(1)
lastCell = .Cells(.Rows.Count, searchColumn).End(xlUp).Row
For Each myCell In .Range(.Cells(1, searchColumn), .Cells(lastCell, searchColumn))
If myCell.Value <> "" And InStr(1, myCell, "_") Then
.Cells(myCell.Row, replaceColumn) = Split(myCell, "_")(1)
End If
Next
End With
End Sub
This is the function, locating the columns. (If you have ideas for improvement, feel free to make a PR here):
Public Function LocateValueCol(ByVal textTarget As String, _
ByRef wksTarget As Worksheet, _
Optional rowNeeded As Long = 1, _
Optional moreValuesFound As Long = 1, _
Optional lookForPart = False, _
Optional lookUpToBottom = True) As Long
Dim valuesFound As Long
Dim localRange As Range
Dim myCell As Range
LocateValueCol = -999
valuesFound = moreValuesFound
Set localRange = wksTarget.Range(wksTarget.Cells(rowNeeded, 1), wksTarget.Cells(rowNeeded, Columns.Count))
For Each myCell In localRange
If lookForPart Then
If textTarget = Left(myCell, Len(textTarget)) Then
If valuesFound = 1 Then
LocateValueCol = myCell.Column
If lookUpToBottom Then Exit Function
Else
Decrement valuesFound
End If
End If
Else
If textTarget = Trim(myCell) Then
If valuesFound = 1 Then
LocateValueCol = myCell.Column
If lookUpToBottom Then Exit Function
Else
Decrement valuesFound
End If
End If
End If
Next myCell
End Function
Private Sub Increment(ByRef valueToIncrement As Variant, Optional incrementWith As Double = 1)
valueToIncrement = valueToIncrement + incrementWith
End Sub
Private Sub Decrement(ByRef valueToDecrement As Variant, Optional decrementWith As Double = 1)
valueToDecrement = valueToDecrement - decrementWith
End Sub
For fun using regex and dynamically finding header columns. You can swop out the regex based function for your own and still have the dynamic column finding.
Option Explicit
Public Sub test()
Dim i As Long, inputs(), re As Object, ws As Worksheet
Dim inputColumn As Range, outputColumn As Range, inputColumnNumber As Long, outputColumnNumber As Long
Const SEARCH_ROW As Long = 1
Const INPUT_HEADER As String = "Crude items"
Const OUTPUT_HEADER As String = "Refined Ones"
Const START_ROW = 2
Set re = CreateObject("VBScript.RegExp")
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set inputColumn = GetColumnByHeader(ws, SEARCH_ROW, INPUT_HEADER)
Set outputColumn = GetColumnByHeader(ws, SEARCH_ROW, OUTPUT_HEADER)
If inputColumn Is Nothing Or outputColumn Is Nothing Then Exit Sub
inputColumnNumber = inputColumn.Column
outputColumnNumber = outputColumn.Column
With ws
inputs = Application.Transpose(.Range(.Cells(START_ROW, inputColumnNumber), .Cells(.Cells(.Rows.Count, inputColumnNumber).End(xlUp).Row, inputColumnNumber)).Value)
For i = LBound(inputs) To UBound(inputs)
inputs(i) = GetMatch(re, inputs(i))
Next
.Cells(START_ROW, outputColumnNumber).Resize(UBound(inputs), 1) = Application.Transpose(inputs)
End With
End Sub
Public Function GetColumnByHeader(ByVal ws As Worksheet, ByVal SEARCH_ROW As Long, ByVal columnName As String) As Range
Set GetColumnByHeader = ws.Rows(SEARCH_ROW).Find(columnName)
End Function
Public Function GetMatch(ByVal re As Object, ByVal inputString As String) As String
With re
.Global = True
.MultiLine = True
.Pattern = "_(.*)"
If .test(inputString) Then
GetMatch = .Execute(inputString)(0).SubMatches(0)
Else
GetMatch = inputString 'or =vbNullString if want to return nothing
End If
End With
End Function
If you are working through an actual table things will become quite easy:
Sub Test()
Dim arr(), x As Long
With ThisWorkbook.Sheets("Sheet1") 'Change accordingly
For Each cl In .Range("Table1[Crude Items]") 'Change Table1 accordingly
ReDim Preserve arr(x)
If InStr(cl, "_") > 0 Then
arr(x) = Split(cl, "_")(1)
Else
arr(x) = ""
End If
x = x + 1
Next cl
.Range("Table1[Refined Ones]").Value = Application.Transpose(arr)
End With
End Sub
There is a check for "_". If not there, the cell will be kept empty.
You can also consider to use formula to do it.
I am not clear about what you want to replace "_" character with. For example, iff you replace the following line of your script:
Sheets("Sheet1").Range(cel(1, 3).Address) = Split(cel, "_")(1)
with this one:
Sheets("Sheet1").Range(cel(1, 3).Address) = WorksheetFunction.Substitute(cel, "_", "")
The above line should replace the "_" character with nothing from the cells in the Crude_Items column
And as Lee said, you can also consider using formula in the worksheet if you do not have significant amount of data