I've come up with the following to alternate row colors within a specified range:
Sub AlternateRowColors()
Dim lastRow as Long
lastRow = Range("A1").End(xlDown).Row
For Each Cell In Range("A1:A" & lastRow) ''change range accordingly
If Cell.Row Mod 2 = 1 Then ''highlights row 2,4,6 etc|= 0 highlights 1,3,5
Cell.Interior.ColorIndex = 15 ''color to preference
Else
Cell.Interior.ColorIndex = xlNone ''color to preference or remove
End If
Next Cell
End Sub
That works, but is there a simpler method?
The following lines of code may be removed if your data contains no pre-exisiting colors:
Else
Cell.Interior.ColorIndex = xlNone
I need to do this frequently and like to be able to easily modify the colors I'm using for the banding. The following sub makes it very easy:
Sub GreenBarMe(rng As Range, firstColor As Long, secondColor As Long)
rng.Interior.ColorIndex = xlNone
rng.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),2)=0"
rng.FormatConditions(1).Interior.Color = firstColor
rng.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),2)<>0"
rng.FormatConditions(2).Interior.Color = secondColor
End Sub
Usage:
Sub TestGreenBarFormatting()
Dim rng As Range
Dim firstColor As Long
Dim secondColor As Long
Set rng = Range("A1:D12")
firstColor = vbGreen
secondColor = vbYellow
Call GreenBarMe(rng, firstColor, secondColor)
End Sub
Alternating row colors can be done using conditional formatting:
I needed a macro that would color every second row in a range, using only those rows that were visible. This is what I came up with. You don't have to loop through the rows.
Sub Color_Alt_Rows(Rng As Range)
Application.ScreenUpdating = False
Rng.Interior.ColorIndex = xlNone
Rng = Rng.SpecialCells(xlCellTypeVisible)
Rng.FormatConditions.Add Type:=xlExpression, Formula1:="=mod(row()+1,2)"
Rng.FormatConditions(1).Interior.ColorIndex = 34
End Sub
Try it out with Color_Alt_Rows Range("a2:d5")
My Solution
A subroutine to assign to a button or some code
Public Sub Band_Goals()
'Just pass the start and end rows
'You will have to update the function to select the
'the correct columns
BandRows_Invisble 12, 144
End Sub
The Function
Private Sub BandRows_Invisble(StartRow As Integer, EndRow As Integer)
Dim i As Long, nothidden As Boolean
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Range("A" & StartRow & ":K" & EndRow).Interior.ColorIndex = xlNone
For i = StartRow To EndRow
If Not Rows(i).Hidden Then
nothidden = nothidden + 1
If Not nothidden Then
'Download this app to help with color picking
'http://www.iconico.com/download.aspx?app=ColorPic
Range("A" & i & ":K" & i).Interior.Color = RGB(196, 189, 151)
End If
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
'--- Alternate Row color, only non-hidden rows count
Sub Test()
Dim iNumOfRows As Integer, iStartFromRow As Integer, iCount As Integer
iNumOfRows = Range("D61").End(xlDown).Row '--- counts Rows down starting from D61
For iStartFromRow = 61 To iNumOfRows
If Rows(iStartFromRow).Hidden = False Then '--- only non-hidden rows matter
iCount = iCount + 1
If iCount - 2 * Int(iCount / 2) = 0 Then
Rows(iStartFromRow).Interior.Color = RGB(220, 230, 241)
Else
Rows(iStartFromRow).Interior.Color = RGB(184, 204, 228)
End If
End If
Next iStartFromRow
End Sub
Well, you can delete the else part, since you will leave it in the default color
In my Excel 2010, there is an option to format as table, where you can also select a range and headers. No need for scripting.
set these up initialized somewhere:
Dim arr_Lng_Row_Color(1) As Long
arr_Lng_Row_Color(0) = RGB(int_Color_1_R, int_Color_1_G, int_Color_1_B)
arr_Lng_Row_Color(1) = RGB(int_Color_2_R, int_Color_2_G, int_Color_2_B)
On any row you wish this will set the color
ws_SomeSheet.Rows(int_Target_Row).EntireRow.Interior.Color = arr_Lng_Row_Color(int_Target_Row Mod 2)
Related
Edit: Now its working much better but the code starts deleting non-black text from other columns as well ?_? the code works for other worksheets so I'm not sure why it only doesn't work for this one... :"( pls help
I have an excel sheet with text that has multiple colors in the same cell e.g. blue and black words in the same cell. I want to remove all the blue words. I wrote a loop that loops through the cells and every character in the cells in the entire column and writes the black words back to each cell. However it takes a really long time so its not very feasible. Also I tried using arrays but I'm not sure how to store the format alongside the value into the array :"( Thanks!
Sub deletecommentsRight_New()
Dim lrow As Long
Dim textOut As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
lrow = LastRow()
Range("M1:M" & lrow).Select
For Each Cell In Selection
textOut = ""
For i = 1 To Len(Cell)
If (((Cell.Characters(i, 1).Font.ColorIndex = 1) Or (Cell.Characters(i, 1).Font.ColorIndex = -4105)) And Not (Cell.Characters(i, 1).Font.Strikethrough)) Then
textOut = textOut & Mid(Cell, i, 1)
End If
Next
Cell.Value = textOut
Cell.Font.ColorIndex = 1
Next Cell
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Public Function LastRow() As Long
'Finds the last non-blank cell on a sheet/range.
Dim lrow As Long
Dim lCol As Long
lrow = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
LastRow = lrow
End Function
First of all, you should always use Option Explicit at the top of your modules so that it forces you to declare all variables properly.
There is no need to loop through an entire column. Only loop through cells that actually have values. For that we can use the Worksheet.UsedRange property and do an Intersect with the desired range.
Also code should be able to ignore errors and numbers since you are only interested in texts.
Also, there is no need to read the cell value multiple times so best is to read them just once using an array. A With construct can help in reading the cell font colors easily.
Here is what I came up with - kept the original method name:
Option Explicit
Public Sub DeleteComments(ByVal rng As Range)
Dim tempRng As Range
Dim tempArea As Range
Set tempRng = GetUsedRange(rng)
If tempRng Is Nothing Then Exit Sub
'Store app state and turn off some features
Dim scrUpdate As Boolean: scrUpdate = Application.ScreenUpdating
Dim calcMode As XlCalculation: calcMode = Application.Calculation
Dim evEnabled As Boolean: evEnabled = Application.EnableEvents
With Application
If .ScreenUpdating Then .ScreenUpdating = False
If calcMode <> xlCalculationManual Then .Calculation = xlCalculationManual
If .EnableEvents Then .EnableEvents = False
End With
'Loop through all areas. Check/update only relevant values
For Each tempArea In tempRng.Areas
If tempArea.Count = 1 Then
UpdateCell tempArea, tempArea.Value2
Else
Dim arr() As Variant: arr = tempArea.Value2 'Read whole range into array
Dim rowsCount As Long: rowsCount = tempArea.Rows.Count
Dim i As Long: i = 1
Dim j As Long: j = 1
Dim v As Variant
'For Each... loop is faster than using 2 For... Next loops on a 2D array
For Each v In arr 'Column-major order
If VarType(v) = vbString Then 'Only check strings - ignore numbers and errors
If Len(v) > 0 Then UpdateCell tempArea.Cells(i, j), v
End If
i = i + 1
If i > rowsCount Then 'Switch to the next column
j = j + 1
i = 1
End If
Next v
End If
Next tempArea
'Restore app state
With Application
If scrUpdate Then .ScreenUpdating = True
If calcMode <> xlCalculationManual Then .Calculation = calcMode
If evEnabled Then .EnableEvents = True
End With
End Sub
Private Function GetUsedRange(ByVal rng As Range) As Range
If rng Is Nothing Then Exit Function
On Error Resume Next
Set GetUsedRange = Intersect(rng, rng.Worksheet.UsedRange)
On Error GoTo 0
End Function
Private Function UpdateCell(ByVal cell As Range, ByVal value As Variant)
Dim textOut As String
Dim charExcluded As Boolean
Dim i As Long
For i = 1 To Len(value)
With cell.Characters(i, 1).Font
If (.ColorIndex = 1 Or .ColorIndex = -4105) And Not .Strikethrough Then
textOut = textOut & Mid$(value, i, 1)
Else
charExcluded = True
End If
End With
Next i
If charExcluded Then cell.Value2 = textOut
If IsNull(cell.Font.ColorIndex) Then
cell.Font.ColorIndex = 1
ElseIf cell.Font.ColorIndex <> 1 Then
cell.Font.ColorIndex = 1
End If
End Function
As you can see, I've split the code in a few auxiliary functions so that is easier to maintain.
To use it just call it on the desired range. For example:
DeleteComments Selection 'if you already have a selected range
'Or
DeleteComments Range("M:M") 'as in your original post
An added benefit is that this code works regardless if your desired range is a column, a row, multiple columns/rows or even multi-area ranges. Gives you a lot of flexibility and is as fast as you could make it.
Edit #1
The UpdateCell function could be faster if we only check cells with mixed colors:
Private Function UpdateCell(ByVal cell As Range, ByVal value As Variant)
Dim textOut As String
Dim charExcluded As Boolean
Dim i As Long
If IsNull(cell.Font.ColorIndex) Then
For i = 1 To Len(value)
With cell.Characters(i, 1).Font
If (.ColorIndex = 1 Or .ColorIndex = -4105) And Not .Strikethrough Then
textOut = textOut & Mid$(value, i, 1)
Else
charExcluded = True
End If
End With
Next i
If charExcluded Then cell.Value2 = textOut
cell.Font.ColorIndex = 1
ElseIf cell.Font.ColorIndex <> 1 Then
cell.Value2 = Empty
cell.Font.ColorIndex = 1
End If
End Function
You are doing this for over a million cells, most of them are empty. If you start by checking that the cell is not empty, you might heavily improve the performance.
Building on the suggestions provided, here is the modified code. Since the original code worked on selection, an option to ask the user to select a range is opted than defining fixed ranges.
Sub deletecomments()
Dim textOut As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'----------------------------
Dim myrange As Range
ThisWorkbook.Sheets("Sheet1").Activate 'Change Workbook and Sheet name accordingly
Set myrange = Application.InputBox(Title:="Range Selector", Prompt:="Please select your Range.", Type:=8)
'--------------------------
For Each Cell In myrange 'Replace selection with myRange
textOut = ""
For i = 1 To Len(Cell)
If (((Cell.Characters(i, 1).Font.ColorIndex = 1) Or (Cell.Characters(i, 1).Font.ColorIndex = -4105)) And Not (Cell.Characters(i, 1).Font.Strikethrough)) Then
textOut = textOut & Mid(Cell, i, 1)
End If
Next
Cell.value = textOut
Cell.Font.ColorIndex = 1
Next Cell
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I have data such that single cells contain multiple bit of info.
Using conditional formatting excel can recognise cells which contain a phrase however the conditional format is applied to the cell as a whole. I'm aiming to try and Highlight the Specific text "Not Provided" in Red.
Looking online it looks like this will be a VBA solution.
To start, I have found the following code online however this doesnt appear to change the colour as desired.
Sub Test1()
Dim strString$, x&
Dim rngCell As Range
strString = Range("B1").Value
Application.ScreenUpdating = False
For Each rngCell In Range("G1", Range("G" & Rows.Count).End(xlUp))
With rngCell
.Font.ColorIndex = 1
For x = 1 To Len(.Text) - Len(strString) Step 1
If Mid(.Text, x, Len(strString)) = strString Then .Characters(x, Len(strString)).Font.ColorIndex = 5
Next x
End With
Next rngCell
Application.ScreenUpdating = True
End Sub
If someone could point out either how I can get the code above working to explore if this will be useful for my purposes or even if someone knows how to conditionally format specific words that would be great. Ultimately I wish for every instance of "Not Provided" across the worksheet to be highlighted in this way.
You can use InStr() to find substring instead of For loop
Sub Test1()
Dim strString As String, x As Long, rngCell As Range
strString = Range("B1").Value
Application.ScreenUpdating = False
For Each rngCell In Range("G1", Range("G" & Rows.Count).End(xlUp))
x = InStr(1, rngCell.Value2, strString, vbTextCompare)
If x > 0 Then
With rngCell
.Font.ColorIndex = 1
.Characters(x, Len(strString)).Font.ColorIndex = 3 'red color
End With
End If
Next
Application.ScreenUpdating = True
End Sub
To dynamically change the color of the text, as in conditional formatting, you can use the Change event:
'place it into the Worksheet module
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim strString As String, x As Long, rngCell As Range, rng As Range
Set rng = Intersect(Target, Me.Columns("G"))
If rng Is Nothing Then Exit Sub
Application.EnableEvents = False
Application.ScreenUpdating = False
strString = Range("B1").Value
For Each rngCell In rng
x = InStr(1, rngCell.Value2, strString, vbTextCompare)
If x > 0 Then
With rngCell
.Font.ColorIndex = 1
.Characters(x, Len(strString)).Font.ColorIndex = 3 'red color
End With
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
I would like to merge similar cells by columns, as of now I am using this macro
Sub MergeSimilarCells()
Set myRange = Range("A1:Z300")
CheckAgain:
For Each cell In myRange
If cell.Value = cell.Offset(0, 1).Value And Not IsEmpty(cell) Then
Range(cell, cell.Offset(0, 1)).Merge
cell.VerticalAlignment = xlCenter
cell.HorizontalAlignment = xlCenter
GoTo CheckAgain
End If
Next
End Sub
My problem is with hundreds of rows and 40-50 columns, it takes forever.
I am pretty sure a For Loop could help me there but I am not skilled enough to figure it out
I know the following code is wrong but I am lost
Sub SimilarCells()
Set myRange = Range("A1:G4")
Dim count As Integer
CheckAgain:
count = 1
For Each cell In myRange
If cell.Value = cell.Offset(0, 1).Value And Not IsEmpty(cell) Then
count = count + 1
ElseIf cell.Value <> cell.Offset(0, 1).Value Then
Range(cell, cell.Offset(0, -count)).Merge
End If
Next
End Sub
Here is what I would like to accomplish
Sub MergeMe()
Dim wks As Worksheet: Set wks = Worksheets(1)
Dim myRange As Range: Set myRange = wks.Range("B2:H5")
Dim myCell As Range
Dim myCell2 As Range
Dim firstColumn As Long: firstColumn = myRange.Columns(1).column + 1
Dim lastColumn As Long: lastColumn = firstColumn + myRange.Columns.Count - 1
Dim firstRow As Long: firstRow = myRange.Rows(1).row
Dim lastRow As Long: lastRow = firstRow + myRange.Rows.Count - 1
Dim column As Long
Dim row As Long
OnStart
For column = lastColumn To firstColumn Step -1
For row = lastRow To firstRow Step -1
Set myCell = wks.Cells(row, column)
Set myCell2 = myCell.Offset(0, -1)
If myCell.Value = myCell2.Value Then
With wks.Range(myCell, myCell2)
.Merge
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
End With
End If
Next row
Next column
OnEnd
End Sub
There are quite a few tricks in this code:
we need to get the first and last column and row;
then we should be looping from the last cell (bottom right) to the first one (top left);
we should not enter the first column, because we are using .Offset(0,-1) and we compare every cell with its leftmost one;
the reason for the whole operation, is that by default, the value of a merged cells is kept in its left top cell. The other cells of a merged cell are without a value.
This is why we always compare the merged cells with their "left" neighbour;
These are the OnEnd and OnStart, facilitating the operation.
Public Sub OnEnd()
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
Application.StatusBar = False
End Sub
Public Sub OnStart()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
ActiveWindow.View = xlNormalView
End Sub
Only one merge per group
EDITED to fix - thanks Vityata for the heads-up
Sub MergeEm()
Dim rw As Range, i As Long, s As Long, v
Range("C21:J33").Copy Range("C5:J17") 'for testing purposes: replace previous run
Application.ScreenUpdating = False
For Each rw In Range("C5:J17").Rows 'or wherever
i = 1
s = 1
Do While i < (rw.Cells.Count)
v = rw.Cells(i).Value
'check for a run of same values
Do While Len(v) > 0 And v = rw.Cells(i + s).Value
s = s + 1
If i + s > rw.Cells.Count Then Exit Do
Loop
'if s>1 then had a run: merge those ells
If s > 1 Then
Application.DisplayAlerts = False
rw.Cells(i).Resize(1, s).Merge
rw.Cells(i).HorizontalAlignment = xlCenter
Application.DisplayAlerts = True
i = i + s 'skip over the merged range
s = 1 'reset s
Else
i = i + 1
End If
Loop
Next rw
End Sub
I'm pretty sure what bloats your processing time is the goto causing you to loop through everything yet again every time after every merge
Edit to take column A into account and prevent first column cells to merge with cells outside of myRange:
Sub MergeSimilarCells()
Dim i As Long
Dim myCol As String
Set myRange = Range("K1:L30")
myCol = Left(myRange.Address(True, False), InStr(myRange.Offset(0, 1).Address(True, False), "$") - 1)
If Not Intersect(myRange, Range(myCol & ":" & myCol)).Address = myRange.Address Then
Set myRange = Range(Replace(myRange.Address, Left(myRange.Address(True, False), _
InStr(myRange.Address(True, False), "$")), Left(myRange.Offset(0, 1).Address(True, False), _
InStr(myRange.Offset(0, 1).Address(True, False), "$"))))
For i = myRange.Cells.Count To 1 Step -1
If myRange.Item(i).Value = myRange.Item(i).Offset(0, -1).Value And Not IsEmpty(myRange.Item(i)) Then
Range(myRange.Item(i), myRange.Item(i).Offset(0, -1)).Merge
myRange.Item(i).VerticalAlignment = xlCenter
myRange.Item(i).HorizontalAlignment = xlCenter
End If
Next
End If
End Sub
To clarify why myRange has to start in column B: Offset(0, -1) of any cell in column A will cause an error since there is no column to the left of A.
I am stuck with a problem i cannot get my head around currently.
I have a checklist that has to update automatically when adding lines to my excel worksheet so that the checklist is applied to all rows.
I tried to use a "for loop" to modify the formula but excel returns Error 1004, when starting the string with "=".
No error but no functionality as well:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").FormulaLocal = "Wenn(Oder(AB" & firstRow & "=""x"""
Returns error 1004:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").FormulaLocal = "=Wenn(Oder(AB" & firstRow & "=""x"""
My first solution
Loop FormulaR1C1, or Formula and use nothing but english Function names eg. sum() instead of Summe() and follow english syntax , instead of ;.
Problem
When testing the syntax without a loop and actual indices it works like a charm. As soon as I try to loop it, Excel does not recognize R[i]C as cell anymore but just returns plain text.
no issues:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Formula = "IF(OR( R[1]C = ""x"""
issues:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Formula = "IF(OR( R[i]C = ""x"""
Splitting it like this did not solve my problem either
..R[" & i & "]C =..
Any tips?
// For i= ... to .. next i
// Excel 2007
Try this:
With ActiveWorkbook.Sheets("Kalkulation Änderungen")
'find last row of column AB
LastRow = .Cells(.Rows.Count, "AB").End(xlUp).Row
'apply the formula from AB9 to its last non-blank row
.Range("AB9:AB" & LastRow).Formula = "IF(OR( R[1]C = ""x"""
End With
#UGP: that is what i thought the code might look like after implementing your tips with intersect etc.
What do you think of it, I guess you might not like the loops too much?
Typical beginner approach to loop everything?
I would have to do this for every column accordingly?
If so it would be wise to create a sub () for every column with an exit condition so that i save computing time?
Unless it is possible to hand over the columnadress to the sub_worksheet_change()?
Private Sub Worksheet_Change(ByVal Target As Range, selected_column)
_
_
_
_
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim i As Integer
Dim check As Boolean
frstRow = 1
lastRow = 1
i = 1
'Rowcount
Do Until firstRow <> 1 And lastRow <> 1
If ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("D" & i) = "Länge" Then
firstRow = i + 2
i = i + 1
End If
If ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("G" & i) = "Gesamt-h" Then
lastRow = i - 2
End If
i = i + 1
Loop
' check column AB fo "x" and modify header
Set KeyCells = Range("AB" & firstRow, "AI" & lastRow)
check = False
i = firstRow
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
Do While i <= lastRow And check = False
If ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB" & i).Value = "x" Then
check = True
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Value = "x"
ElseIf i = lastRow And check = False Then
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Value = " "
End If
i = i + 1
Loop
End If
End Sub
Here's the code. It has to be in the corresponding worksheet in the VBA-Editor.
It activates when a cell in Range(A10:A20) has been changed.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A10:A20")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If Target.Count = 1 Then
If Target.Value = "x" Then
'Your Code
'i.e
MsgBox (Target.Address & "has been changed")
End If
Else
MsgBox ("Please No Copy Pasterino")
End If
End If
End Sub
EDIT:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim i As Integer
Dim fRow As Long, lRow As Long
Dim check As Boolean
Dim sht As Worksheet
Dim Cell As Range
Set sht = Worksheets("Tabelle1")
'Rowcount
fRow = 2
lRow = sht.Cells(sht.Rows.Count, "G").End(xlUp).Row
' check column AB fo "x" and modify header
Set KeyCells = Range("AB" & fRow & ":AI" & lRow)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
For Each Cell In Range(Cells(fRow, Target.Column), Cells(lRow, Target.Column))
If Cell.Value = "x" Then
sht.Cells(9, Target.Column).Value = "x"
Exit For
Else
sht.Cells(9, Target.Column).Value = ""
End If
Next
End If
End Sub
I'm trying to use a shape instead of a button to toggle hiding rows with blank cells (according to conditions). Is it even possible?
Sub ToggleChevron3_Click()
Dim rng As Range, cell As Range
Set rng = Range("A1:C100")
Application.ScreenUpdating = False
With rng
For Each cell In rng
If cell.Offset(0, 4).Value = "" Then ' Condition 1
If cell.Value = "" Then ' Condition 2
ActiveSheet.Shapes("Chevron 3").cell.EntireRow.Hidden _
= Not ActiveSheet.Shapes("Chevron 3").cell.EntireRow.Hidden
End If
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Yes, it is possible. The code to accomplish what I think you are looking for is below. Both pieces of code below assume you want to just click a button to hide / unhide the rows, depending on the current state.
Sub ToggleChevron3_Click()
Application.ScreenUpdating = False
Dim rng As Range, cell As Range
'Set rng = Range("A1:C100") 'do you really want to loop through every cell in columns A through C
Set rng = Range("A1:A100")
For Each cell In rng
If Len(cell.Offset(, 4).Value) = 0 And Len(cell.Value) = 0 Then
Dim bToggle As Boolean
bToggle = cell.EntireRow.Hidden
cell.EntireRow.Hidden = Not bToggle
End If
Next
Application.ScreenUpdating = True
End Sub
However, there is alternative that is cleaner code and faster execution, as long as filtering is okay for you.
Sub ToggleChevron3_Click()
Application.ScreenUpdating = False
Dim bToggle As Boolean
bToggle = ActiveSheet.AutoFilterMode
If bToggle Then
ActiveSheet.AutoFilterMode = False
Else
Dim rng As Range
Set rng = Range("A1:E100") 'used E because you had an offset of 4 columns
With rng
.AutoFilter 5, "<>"
.AutoFilter 1, "<>"
End With
End If
Application.ScreenUpdating = True
End Sub