Looking for a simple loop through the range (say column A range("A5:A15")) if there is a blank cell within that range I need the entire row/rows associated with the blank cell/cells to be hidden.
I was thinking of something like this to accommodate various ranges but get "type Mismatch" error. Any reasons why
Sub test()
Dim rng As Range, cell As Variant, ar As Variant
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range
Dim MyArray(1 To 4) As Range
With ThisWorkbook.Worksheets("sheet1")
'Set MyArray = rng
Set MyArray(1) = Range("O8:O17")
Set MyArray(2) = Range("O55:O64")
Set MyArray(3) = Range("G37:G46")
Set MyArray(4) = Range("G89:G98")
'ar = Array(Rng1, Rng2, Rng3, Rng4)
'Set rng = .Range("O8:O17")
For Each cell In MyArray
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next cell
End With
End Sub
?
Something Like this:
You can put it in a subject:
For Each cell In Range("A5:A15")
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next
For Each cell In Range("A40:A55")
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next
New Answer :
Dim rng As Range, cell As Variant, ar As Variant
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range
Dim MyArray(1 To 4) As Range
With ThisWorkbook.Worksheets("sheet1")
'Set MyArray = rng
Set MyArray(1) = Range("O8:O17")
Set MyArray(2) = Range("O55:O64")
Set MyArray(3) = Range("G37:G46")
Set MyArray(4) = Range("G89:G98")
'ar = Array(Rng1, Rng2, Rng3, Rng4)
'Set rng = .Range("O8:O17")
Dim i As Integer
For i = LBound(MyArray) To UBound(MyArray)
For Each cell In MyArray(i)
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next
Next
End With
Try:
Option Explicit
Sub test()
Dim rng As Range, cell As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .Range("A5:A15")
For Each cell In rng
If cell.Value = "" Then
.Rows(cell.Row).EntireRow.Hidden = True
End If
Next cell
End With
End Sub
This takes full advantage of the Excel VBA model. I'm guessing it's faster than the above but have not conducted performance tests.
Dim Cell As Range
For Each Cell In Range("A5:A15").SpecialCells(xlCellTypeBlanks)
Cell.EntireRow.Hidden = True
Next
Try the following
Option Explicit
Sub youcouldhaveatleasttriedtodosomethingyourself()
Dim r1 As Range, r2 As Range, c As Range, target As Range
With Workbooks(REF).Sheets(REF)
Set r1 = .Range("A1:A54")
Set r2 = .Range("F3:F32")
Set target = Application.Union(r1, r2)
For Each area In target.Areas
For Each c In area
If c.Value = vbNullString Then .Rows(c.Row).EntireRow.Hidden = True
Next c
Next area
End With
End Sub
Please note that I now have set two exemplifying ranges. You can always add more range variables to the Union function.
Related
I Have Range1(S4:W8) and Range2(J4:N18).
I want to create a Macro that will check if any cells between the two ranges are equal to each other, and if so, highlight. Depending on the scenario, Range2 may have few, or many blank cells.
Below is My attempt. "*****" is a placeholder for me because I don't know what to put there.
Dim R1 As Range
Set R1 = Range("S4:W8")
Dim R2 As Range
Set R2 = Range("J4:N18")
For Each Cell In R1
If Cell.Value ***** Then
Cell.Interior.ColorIndex = 6
End If
Next
End Sub
There's a lot of ways to do this, but here's a simple method that might help you with understanding loops and ranges. I presume you don't want to use conditional formatting for something like this.
I changed up your variables a little for clarity, and added an exit for since once you match a color no need to keep searching.
Sub doTHis()
Dim aRng As Range, gRng As Range, aCell As Range, gCell As Range
'probably should scope the sheet too
Set aRng = Range("S4:W8")
Set gRng = Range("J4:N18")
For Each aCell In aRng.Cells
For Each gCell In gRng.Cells
If gCell.Value = aCell.Value Then
aCell.Interior.ColorIndex = 6
Exit For ' no need to keep searching
End If
Next gCell
Next aCell
End Sub
If you want simplicity over performance, you could use this code:
Sub findInRange()
Dim R1 As Range
Set R1 = Range("S4:W8")
Dim R2 As Range
Set R2 = Range("J4:N18")
Dim fnd As Range
' search R2 for cell in R1
For Each cell In R1
Set fnd = R2.Find(cell.Value, lookat:=xlWhole)
If Not fnd Is Nothing Then
' colour matched cells
cell.Interior.ColorIndex = 6
Else
' reset colour in unmatched cells
cell.Interior.ColorIndex = 0
End If
Next
End Sub
Highlight Column Matches
This will highlight matches per column i.e. each range has the same number of columns, so it will find matches of the cells in columns of the source range in cells in the respective columns of the destination range and highlight them in yellow.
Option Explicit
Sub HighlightColumnMatches()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim srg As Range: Set srg = ws.Range("J4:N18")
Dim drg As Range: Set drg = ws.Range("S4:W8")
Dim drCount As Long: drCount = drg.Rows.Count
Dim dData As Variant: dData = drg.Value
Dim scrg As Range
Dim sIndex As Variant
Dim durg As Range
Dim dr As Long
Dim dc As Long
For dc = 1 To drg.Columns.Count
Set scrg = srg.Columns(dc)
For dr = 1 To drCount
sIndex = Application.Match(dData(dr, dc), scrg, 0)
If IsNumeric(sIndex) Then
If durg Is Nothing Then
Set durg = drg.Cells(dr, dc)
Else
Set durg = Union(durg, drg.Cells(dr, dc))
End If
End If
Next dr
Next dc
If Not durg Is Nothing Then
drg.Interior.Color = xlNone
durg.Interior.Color = vbYellow
End If
MsgBox "Matches highlighted.", vbInformation
End Sub
Please, test the next way. It should be very fast for large ranges, using arrays, placing the cells to be colored in a Union range and color them at the code end. It also skips the empty cells to be compared:
Sub testMatchRngValues()
Dim R1 As Range, R2 As Range, rngCol As Range, arr1, arr2, i As Long, j As Long, i1 As Long, j1 As Long
Set R1 = Range("S4:W8"): arr1 = R1.Value 'place the range in an array for faster interation
Set R2 = Range("J4:N18"): arr2 = R2.Value 'place the range in an array for faster interation
For i = 1 To UBound(arr1)
For j = 1 To UBound(arr1, 2)
For i1 = 1 To UBound(arr2)
For j1 = 1 To UBound(arr2, 2)
If arr1(i, j) = arr2(i1, j1) And arr1(i, j) <> "" Then
If rngCol Is Nothing Then
Set rngCol = R1.cells(i, j)
Else
Set rngCol = Union(rngCol, R1.cells(i, j))
End If
Exit For
End If
Next j1
Next i1
Next j
Next i
If Not rngCol Is Nothing Then rngCol.Interior.ColorIndex = 6
End Sub
Not tested, but it should work as you need...
If your ranges are really equal in terms of rows/columns, as you say in your comment, please try the next code:
Sub testMatchRngValues2()
Dim R1 As Range, R2 As Range, rngCol As Range, arr1, arr2, i As Long, j As Long
Set R1 = Range("S4:W18"): arr1 = R1.Value 'place the range in an array for faster interation
Set R2 = Range("J4:N18"): arr2 = R2.Value 'place the range in an array for faster interation
R1.Interior.color = xlNone 'clear any cell interior color
For i = 1 To UBound(arr1)
For j = 1 To UBound(arr1, 2)
If arr1(i, j) = arr2(i, j) And arr1(i, j) <> "" Then
If rngCol Is Nothing Then
Set rngCol = R1.cells(i, j)
Else
Set rngCol = Union(rngCol, R1.cells(i, j))
End If
End If
Next j
Next i
If Not rngCol Is Nothing Then rngCol.Interior.ColorIndex = 6
End Sub
Using VBA i make to:
Set two ranges
Create an array of all ranges names
Loop the array in order to apply formatting to each range in the array
BUT on line .Interior.Color = vbRed
i receive the below error:
Run-time error '424': Object required
Code
Sub test()
Dim rng1 As Range, rng2 As Range
Dim strRanges As Variant
Dim i As Long
Set rng1 = Sheet1.Range("A1:D1")
Set rng2 = Sheet2.Range("C5:H5")
strRanges = Split("rng1,rng2", ",")
For i = LBound(strRanges) To UBound(strRanges)
With strRanges(i)
.Interior.Color = vbRed
End With
Next i
End Sub
i have already use:
With Range(strRanges(i))
instead of:
With strRanges(i)
without any luck!
Any help will appreciate.
You can do this in just one line if the ranges are in the same worksheet
Sheet1.Range("A1:D1,C5:H5").Interior.Color = vbRed
You can use union if the ranges are in the same worksheet
Dim rng1 As Range, rng2 As Range
Set rng1 = Sheet1.Range("A1:D1")
Set rng2 = Sheet1.Range("C5:H5")
Union(rng1, rng2).Interior.Color = vbRed
You can use real arrays for your ranges if they are in different worksheets
Sub test()
Dim rng(1 To 2) As Range
Set rng(1) = Sheet1.Range("A1:D1")
Set rng(2) = Sheet2.Range("C5:H5")
Dim i As Long
For i = LBound(rng) To UBound(rng)
With rng(i)
.Interior.Color = vbRed
End With
Next i
End Sub
If you don't have numbered range variable names then you can use another array:
Sub test()
Dim rngABC As Range, rngXYZ As Range
Set rngABC = Sheet1.Range("A1:D1")
Set rngXYZ = Sheet1.Range("C5:H5")
Dim ArrRng() As Variant
ArrRng = Array(rngABC, rngXYZ)
Dim rng As Variant
For Each rng In ArrRng
rng.Interior.Color = vbRed
Next rng
End Sub
Note that if you think you have to use numbered variable names like
Dim rng1 As Range, rng2 As Range
this always is a clear sign for using an array instead:
Dim rng(1 To 2) As Range
numbered variable names are a bad practice. Always choose meaningful names.
I have a code that finds and replaces values in one sheet from a list in another sheet. However, I need this code to also highlight the cell, or flag it in some way so that it can be reviewed manually later. Any suggestions?
Here is the code:
Sub ReplaceValues()
Dim FandR As Worksheet
Dim PDH As Worksheet
Dim rng As Range, rngR As Range
Dim i As Long
Dim rngReplacement
Dim c As Range
Dim curVal As String
Set FandR = Sheets("Find and Replace")
Set PDH = ThisWorkbook.Sheets("Paste Data here")
i = PDH.Rows.Count
With PDH
Set rng = .Range("E1", .Range("E" & i).End(xlUp))
End With
With FandR
Set rngR = FandR.Range("H")
End With
For Each c In rngR
curVal = c.Value
c.Interior.Color = vbYellow
With rng
.Replace curVal, c.Offset(0, 1).Value, xlWhole, , True
End With
Next
End Sub
I am trying to insert a new row into a named range. The user selects a "category" from a combo box e.g., Cool Drinks, Beer and Cider, Bitters etc... and then the contents of that category populate another combo box.
I have named the ranges of all of the Categories and would like them to populate the second combo box. I have a code which works by itself:
Dim rng As Range
Dim DailySales As Worksheet
Set DailySales = Worksheets("Daily Sales")
Set rng = DailySales.Range("CoolDrinksDailySales")
For Each rng In DailySales.Range("CoolDrinksDailySales")
Me.CmboName.AddItem rng.Value
Next rng
However, whenever I try to use that in a Select Case, it doesn't work.
Dim rng As Range
Dim DailySales As Worksheet
Set DailySales = Worksheets("Daily Sales")
Select Case Me.CmboType.Value
Case "Cool Drinks"
Set rng = DailySales.Range("CoolDrinksDailySales")
For Each rng In DailySales.Range("CoolDrinksDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Beer and Cider"
Set rng = DailySales.Range("BeerCiderDailySales")
For Each rng In DailySales.Range("BeerCiderDailySales")
Me.CmboName.AddItem rng.Value
Next rng
End Select
Does anybody have any ideas?
Here is the complete code:
Option Explicit
Private Sub UserForm_Initialize()
'InitializeTypeCombo
Dim Types() As String
Types = Split("Cool Drinks,Beer and
Cider,Bitters,Brandy,Whiskey,Rum,Spirits,Sherry,White Wine,Red Wine",
",")
Dim i As Integer
For i = LBound(Types) To UBound(Types)
Me.CmboType.AddItem Types(i)
Next
'InitializeNameCombo
Dim rng As Range
Dim DailySales As Worksheet
Set DailySales = Worksheets("Daily Sales")
Select Case Me.CmboType.Value
Case "Cool Drinks"
Set rng = DailySales.Range("CoolDrinksDailySales")
For Each rng In DailySales.Range("CoolDrinksDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Beer and Cider"
Set rng = DailySales.Range("BeerCiderDailySales")
For Each rng In DailySales.Range("BeerCiderDailySales")
Me.CmboName.AddItem rng.Value
Next rng
End Select
End Sub
Private Sub CmdExit_Click()
Unload Me
End Sub
Private Sub CmdEnter_Click()
Dim rng As Range
'Store Date Index
Dim colArray(32) As Integer
'Store Item Index
Dim rowArray(150) As Integer
'Store first value for Find and FindNext
Dim FirstAddress As String
Dim i As Integer
Dim j As Integer
i = 0
j = 0
With Range("B6:AD6")
Set rng = .Find(TxtDate.Value, LookIn:=xlValues)
If Not rng Is Nothing Then
FirstAddress = rng.Address
Do
Set rng = .FindNext(rng)
colArray(i) = rng.Column
i = i + 1
Loop While Not rng Is Nothing And rng.Address <> FirstAddress
End If
End With
With Range("A7:A150")
Set rng = .Find(CmboName.Value, LookIn:=xlValues)
If Not rng Is Nothing Then
FirstAddress = rng.Address
Do
Set rng = .FindNext(rng)
rowArray(j) = rng.Row
j = j + 1
Loop While Not rng Is Nothing And rng.Address <> FirstAddress
End If
End With
Dim c As Integer
Dim r As Integer
For c = 0 To i - 1
For r = 0 To j - 1
Cells(rowArray(r), colArray(c)).Value = TxtNoSold.Value
Next r
Next c
Unload Me
End Sub
The solution was simply moving the Select Case into the Combobox_Change event. As Dick Kusleika said, the value of the combobox was nothing at runtime. Here is the correct code to accomplish what I was trying to do.
Option Explicit
Private Sub Userform_Initialize()
'Populate cmboTypes
Dim Types() As String
Types = Split("Cool Drinks,Beer and _
Cider,Bitters,Brandy,Whiskey,Rum,Spirits,Sherry,White Wine,_
Red Wine", ",")
'Loop through the values populated in the split function above, and add
'each item to the combobox
Dim i As Integer
For i = LBound(Types) To UBound(Types)
Me.CmboType.AddItem Types(i)
Next
End Sub
Sub CmboType_Change()
Dim rng As Range
Dim DailySales As Worksheet
'Populate CmboName with named dynamic ranges of "Types"
Set DailySales = Worksheets("Daily Sales")
Select Case Me.CmboType.Value
Case "Cool Drinks"
Set rng = DailySales.Range("CoolDrinksDailySales")
For Each rng In DailySales.Range("CoolDrinksDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Beer and Cider"
CmboName.Clear
Set rng = DailySales.Range("BeerCiderDailySales")
For Each rng In DailySales.Range("BeerCiderDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Bitters"
CmboName.Clear
Set rng = DailySales.Range("BittersDailySales")
For Each rng In DailySales.Range("BittersDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Brandy"
CmboName.Clear
Set rng = DailySales.Range("BrandyDailySales")
For Each rng In DailySales.Range("BrandyDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Whiskey"
CmboName.Clear
Set rng = DailySales.Range("WhiskeyDailySales")
For Each rng In DailySales.Range("WhiskeyDailySales")
Me.CmboName.AddItem rng.Value
Next rng
End Select
End Sub
Basically this is the code I have right now. I want to create a module, that in any worksheet, I set the range, then I define certain values (Example: between 0,15 and 0,28) and will finally put a color on the cells with that numbers. But I'm gettting some errors, and I'm having a hard time with the last if.
Sub ColorFrames()
Dim range1 As Range
Dim range2 As Range
Dim valor1 As Variant
Dim valor2 As Variant
Dim Sh As Worksheet
' CODE
Set range1 = Application.InputBox(Prompt:="Please Select Range with data to be validated", Title:="Range", Type:=8)
valor1 = InputBox("Values between:")
valor2 = InputBox("and:")
If valor1 = "" And valor2 = "" Then
' and if < 0 and > 1... How?
MsgBox ("Insert Values between 0 and 1! Thank you")
Exit Sub
End If
For Each Sh In ActiveWorkbook.Sheets
If Range(range1).Value >= valor1 And Range(range1).Value <= valor2 Then
Sh.Interior.ColorIndex = 3
Sh.Value = ""
End If
Next Sh
Exit Sub
End Sub
One option that works on a user range (with the current selection as default) and than loops until a valid range and coundary conditions are supplied is below (for a range on a single sheet)
Sub ColorFrames()
Dim rng1 As Range
Dim rng2 As Range
Dim vArr
Dim dblV1 As Double
Dim dblV2 As Double
Dim bCondition As Boolean
Do
Set rng1 = Application.InputBox(Prompt:="Please Select Range with data to be validated", Title:="Range", Default:=Selection.Address, Type:=8)
Loop While rng1 Is Nothing
Do
vArr = Application.InputBox("Please enter lower and upper bounds, separated by a "", """, Title:="Values", Default:="0,1", Type:=2)
valor1 = Split(vArr, ",")
dblV1 = CDbl(valor1(0))
dblV2 = CDbl(valor1(1))
bCondition = (dblV1 >= 0) And (dvlv2 <= 1) And (dblV2 > dblV1)
Loop While Not bCondition
Application.ScreenUpdating = False
For Each rng2 In rng1
If rng2.Value >= dblV1 And rng2.Value <= dblV2 Then
With rng2
.Interior.ColorIndex = 3
.Value = vbNullString
End With
End If
Next rng2
Application.ScreenUpdating = True
End Sub