How do I simplify this function, to not be repetitive:
If [F11] = "" Or [F12] = "" Or [F13] = "" Or [F14] = "" Or [F15] = "" Or [F16] = "" Or [F17] = "" Or [F18] = "" Or [F19] = "" Or [F20] = "" Or [F21] = "" Then [...]
You can check if any blank cell exist in your range.
Option Explicit
Sub MyAnswer()
Dim rng As Range
Set rng = ActiveSheet.Range("F10:F100")
If rng.SpecialCells(xlCellTypeBlanks).Cells.Count = 0 Then
' Stuff you need
EndIf
End Sub
You can loop the range and break if any cell is ""
Option Explicit
Sub TestBlanks
Dim rngData As Range, rngCell As Range, blnRangeHasBlanks As Boolean
' assume no blanks
blnRangeHasBlanks = False
' iterate range and break on any blank
Set rngData = ThisWorkbook.Worksheets("Sheet1").Range("F11:F21")
For Each rngCell In rngData
If rngCell.Value = "" Then
blnRangeHasBlanks = True
Exit For
End If
Next For
If blnRangeHasBlanks Then
' ... do what you need
End If
End Sub
Related
I am trying to dynamically hide or unhide rows in a worksheet based off of selections within dropdown menus.
The script that I have works with smaller data sets, but because I have 35 different ranges of 26 rows each this slows down really quickly.
I have seen several solutions offered to similar question here, but I have been unable to get them to work.
I want to collect the value in cells B15 down to B41 and hide any rows that have a blank value, then repeat for the remaining 34 ranges.
Each of the cells in the range above have a formula that can return a "" value (which are the rows I want to hide).
Private Sub Worksheet_Change(ByVal Target As Range)
'Turns off worksheet protection to allow for hiding and unhiding of rows
ActiveSheet.Unprotect "xxxx"
'Turns off screen updating and animations while hiding and unhiding rows
Application.EnableAnimations = False
Application.ScreenUpdating = False
Hide1
Hide2
Hide3
Hide4
Hide5
Hide6
Hide7
Hide8
Hide9
Hide10
Hide11
Hide12
Hide13
Hide14
Hide15
Application.ScreenUpdating = True
Application.EnableAnimations = True
ActiveSheet.Protect "xxxx"
End Sub
Sub Hide1()
Application.EnableEvents = False
Application.EnableAnimations = False
Application.ScreenUpdating = False
'Run #1
If Range("B15").Value = "" Then
Rows(15).EntireRow.Hidden = True
Else
Rows(15).EntireRow.Hidden = False
End If
If Range("B16").Value = "" Then
Rows(16).EntireRow.Hidden = True
Else
Rows(16).EntireRow.Hidden = False
End If
If Range("B17").Value = "" Then
Rows(17).EntireRow.Hidden = True
Else
Rows(17).EntireRow.Hidden = False
End If
If Range("B18").Value = "" Then
Rows(18).EntireRow.Hidden = True
Else
Rows(18).EntireRow.Hidden = False
End If
If Range("B19").Value = "" Then
Rows(19).EntireRow.Hidden = True
Else
Rows(19).EntireRow.Hidden = False
End If
If Range("B20").Value = "" Then
Rows(20).EntireRow.Hidden = True
Else
Rows(20).EntireRow.Hidden = False
End If
If Range("B21").Value = "" Then
Rows(21).EntireRow.Hidden = True
Else
Rows(21).EntireRow.Hidden = False
End If
If Range("B22").Value = "" Then
Rows(22).EntireRow.Hidden = True
Else
Rows(22).EntireRow.Hidden = False
End If
If Range("B23").Value = "" Then
Rows(23).EntireRow.Hidden = True
Else
Rows(23).EntireRow.Hidden = False
End If
If Range("B24").Value = "" Then
Rows(24).EntireRow.Hidden = True
Else
Rows(24).EntireRow.Hidden = False
End If
If Range("B25").Value = "" Then
Rows(25).EntireRow.Hidden = True
Else
Rows(25).EntireRow.Hidden = False
End If
If Range("B26").Value = "" Then
Rows(26).EntireRow.Hidden = True
Else
Rows(26).EntireRow.Hidden = False
End If
If Range("B27").Value = "" Then
Rows(27).EntireRow.Hidden = True
Else
Rows(27).EntireRow.Hidden = False
End If
If Range("B28").Value = "" Then
Rows(28).EntireRow.Hidden = True
Else
Rows(28).EntireRow.Hidden = False
End If
If Range("B29").Value = "" Then
Rows(29).EntireRow.Hidden = True
Else
Rows(29).EntireRow.Hidden = False
End If
If Range("B30").Value = "" Then
Rows(30).EntireRow.Hidden = True
Else
Rows(30).EntireRow.Hidden = False
End If
If Range("B31").Value = "" Then
Rows(31).EntireRow.Hidden = True
Else
Rows(31).EntireRow.Hidden = False
End If
Application.EnableEvents = True
Application.EnableAnimations = True
Application.ScreenUpdating = True
End Sub
Please, try the next code. As it is set, it will hide all rows having empty values returned by a formula. firstRand lastR can be chosen to process a specific number of rows:
Sub Hide1()
Dim sh As Worksheet, lastR As Long, firstR As Long
Dim rng As Range, rngH As Range, arr, i As Long
Set sh = ActiveSheet 'use here the sheet you need
lastR = sh.Range("B" & sh.rows.Count).End(xlUp).row 'last row on B:B
firstR = 15 'first row of the range to be processed
Set rng = sh.Range("B" & firstR & ":B" & lastR)
rng.EntireRow.Hidden = False 'show all rows in the range
arr = rng.Value 'place the range in an array for faster iteration
For i = 1 To UBound(arr)
If arr(i, 1) = "" Then
If rngH Is Nothing Then 'set the range to keep the cells where the rows must be hidden
Set rngH = rng.cells(i, 1)
Else
Set rngH = Union(rngH, rng.cells(i, 1))
End If
End If
Next
'hide the rows at once:
If Not rngH Is Nothing Then rngH.EntireRow.Hidden = True
End Sub
Hide Blank Rows
Adjust the values in the constants section.
Option Explicit
Sub HideBlankRows()
Const fCellAddress As String = "B16"
Const crgCount As Long = 35
Const crgSize As Long = 16 ' maybe 26 ?
Const crgGap As Long = 5
Dim ws As Worksheet: Set ws = ActiveSheet
Dim crg As Range: Set crg = ws.Range(fCellAddress).Resize(crgSize)
Dim crgOffset As Long: crgOffset = crgSize + crgGap
Dim rg As Range: Set rg = crg
Dim n As Long
For n = 2 To crgCount
Set crg = crg.Offset(crgOffset)
Set rg = Union(rg, crg)
Next n
Dim drg As Range
Dim cCell As Range
For Each cCell In rg.Cells
If Len(CStr(cCell.Value)) = 0 Then
If drg Is Nothing Then
Set drg = cCell
Else
Set drg = Union(drg, cCell)
End If
End If
Next cCell
If drg Is Nothing Then Exit Sub
rg.EntireRow.Hidden = False
drg.EntireRow.Hidden = True
End Sub
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
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
I have a macro that works perfectly but only if the range has a 1 in the first cell such as the following: Range("E1:E12"). If I want to change the range to Range("E2:E13") it doesn’t paste to the correct cell. The uploaded Excel sheet is the current macro that works but I need to change the range to different cells.
Sub Part()
Dim SearchRange As Range, _
DashPair As Variant, _
PairParts As Variant, _
SearchVal As Variant, _
FoundPos As Variant, _
NextCol As Long
Set SearchRange = Range("E1:E12")
For Each DashPair In Range("B30, F30, J30")
Err.Clear
NextCol = 1
If DashPair.Value <> "" Then
PairParts = Split(DashPair, "-")
If PairParts(1) = "15" Then
SearchVal = DashPair.Offset(RowOffset:=1).Value
On Error Resume Next
Set FoundPos = SearchRange.Find(SearchVal, LookAt:=xlWhole)
If Not FoundPos Is Nothing Then
FoundPos = FoundPos.Row
' find first empty column right of E
While SearchRange(FoundPos).Offset(ColumnOffset:=NextCol).Value <> ""
NextCol = NextCol + 1
Wend
PairParts(1) = PairParts(1) + 1
PairParts = Join(PairParts, "-")
With SearchRange(FoundPos).Offset(ColumnOffset:=NextCol)
.NumberFormat = "#"
.Value = "" & PairParts & ""
End With
DashPair.Resize(ColumnSize:=3).ClearContents
End If
End If '15 found
End If
Next DashPair
End Sub
excel image
Cleaned up the code a little: your issue is with the following: FoundPos = FoundPos.Row as SearchRange(FoundPos) will return the index cell not the cell in the same row
i.e. E2:E15 => E2 is row 2, but SearchRange(2) is E3
* Edit *
Altered next empty cell selection protocol; previous one didn't work as expected
Sub Part()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim Cell As Range, Target As Range, arr As Variant
With ws
Dim SearchRange As Range: Set SearchRange = .Range("E1:E12")
For Each Cell In .Range("B30, F30, J30")
If Cell <> "" Then
arr = Split(Cell, "-")
If UBound(arr) > 0 And arr(1) = "15" Then
On Error Resume Next
Set Target = SearchRange.Find(Cell.Offset(1, 0), LookAt:=xlWhole)
On Error GoTo 0
If Not Target Is Nothing Then
Do While Target <> ""
Set Target = Target.Offset(0, 1)
Loop
With Target
arr(1) = "16"
.NumberFormat = "#"
.value = Join(arr, "-")
Debug.Print Join(arr, "-")
End With
.Range(Cell, Cell.Offset(0, 2)).ClearContents
End If
End If
End If
Next Cell
End With
End Sub
I have a column range of about 500 rows. Most of those cells are stored as text. I populate a listbox on a userform with the values from that range. When a user selects one of those values from the listbox an event will find the value on the same row from another column using Index and Match and display it in a label on the userform. I get an error when selecting one of the few cells in the listbox that are not stored as text in the range because there is a leading space. I am assuming that the populated listbox automatically removes leading spaces from any cells in the range. Therefore, when it tries to find value 12345 from the listbox, for example, in the range it can't find it because the range contains (space)12345. I have tried:
Public Sub UserForm_Initialize()
Dim arr() As Variant
Dim rNum As Range
Const sNum As String = "Number"
Me.EnableEvents = False
wsName = "Report"
Set curWb = ActiveWorkbook
Set pReport = curWb.Worksheets(wsName)
Set pTable = pReport.ListObjects("tableName")
With pReport
If .AutoFilterMode = True Then .ShowAllData
.Cells.Rows.Hidden = False
.Cells.Columns.Hidden = False
End With
Set wf = Application.WorksheetFunction
With pTable
Set rNum = .ListColumns(.ListColumns(sNum).Range.column).DataBodyRange
End With
-- HERE is where I tried all my implementations without success
arr = wf.Transpose(pReport.Range(rNum.address).Value)
Call BubbleSort(arr)
frmIssues.lstIssues1.List = arr
lstIssues1.ListStyle = 1
lstIssues2.ListStyle = 1
lstIssues1.MultiSelect = 2
lstIssues2.MultiSelect = 2
txtFocus.SetFocus
Me.EnableEvents = True
End Sub
Private Sub lstIssues1_Change()
Dim rNum As Range
Dim rTitle As Range
Dim strResult As String
Dim intIndex As Integer
Dim intCount As Integer
Const sNum As String = "Number"
Const sTitle As String = "Title"
If EnableEvents = False Then Exit Sub
With lstIssues1
For intIndex = 0 To .ListCount - 1
If .Selected(intIndex) Then intCount = intCount + 1
Next
End With
If intCount = 1 Then
Set wf = Application.WorksheetFunction
wsName = "Report"
Set curWb = ActiveWorkbook
Set pReport = curWb.Worksheets(wsName)
Set pTable = pReport.ListObjects("tableName")
With pTable
Set rNum = .ListColumns(.ListColumns(sNum).Range.column).DataBodyRange
Set rTitle = .ListColumns(.ListColumns(sTitle).Range.column).DataBodyRange
End With
With pReport
strResult = wf.Index(.Range(rTitle.address), wf.Match(lstIssues1.List(lstIssues1.ListIndex), .Range(rNum.address), 0))
End With
lblDescription.Caption = wf.Trim(strResult)
txtFocus.SetFocus
Else
lblDescription.Caption = ""
txtFocus.SetFocus
Exit Sub
End If
Me.EnableEvents = False
For i = 0 To lstIssues2.ListCount - 1
If lstIssues2.Selected(i) = True Then lstIssues2.Selected(i) = False
Next
Me.EnableEvents = True
End Sub
and numerous variations of it (Clean, CStr, .Text, etc.) and nothing works. Truly, I have no clue how to fix this and any help whatsoever is much appreciated. Thank you!
Clarification
1) This Excel file is generated from the Web.
2) A Macro turns the Worksheet into a table
3) Left(Range("D362"),1) returns 1 (The number, say, is 12345)
4) Before the error occurs Range("D362") returns (space)12345
5) After the error occurs Range("D362") returns (space)12345
I have just tested this and it works in removing the space at the begining of a string. Sadly it isnt a single line as I (and likely you) would have prefered
Sub test()
Dim CellValue As String
Dim lngNumberOfCharacters As Long
CellValue = ActiveCell.Value
CellValueCheck = Left(CellValue, 1)
If CellValueCheck = " " Then
lngNumberOfCharacters = Len(CellValue) - 1
CellValue = Right(CellValue, lngNumberOfCharacters)
ActiveCell.Value = CellValue
End If
End Sub
Let me know if you need anything confirmed