I have Excel two sheets
data like these....
sheet1: 2000, 3000, 4500, 300, 2000, 3000
sheet 2: 300, 2000, 3000, 4550
i run the following code to highlight the values in both sheets with different colors, where value meets with criteria.
but problem is values of sheet1 all 2000, 3000 filled with colors, whereas sheet2 having 2000, 3000 only one time.
if compare with sheet 2 it contains values 2000, 3000 only one time
so sheet1 values first and second fill with colors, rest of values (last two values) should not be in color.
great thanks for solution.
Sub Dupranges()
Dim wr1 As Range, wr2 As Range, Rng1 As Range, Rng2 As Range
Set wr1 = Worksheets("Sheet1").Range("f1:f10")
Set wr2 = Worksheets("Sheet2").Range("g1:g10")
For Each Rng1 In wr1
Rng1.Value = Rng1.Value
For Each Rng2 In wr2
If Rng1.Value = Rng2.Value Then
Rng1.Interior.ColorIndex = 43
Rng2.Interior.ColorIndex = 33
Exit For
End If
Next
Next
MsgBox "Successfully completed"
End Sub
i think i got what you wanted, its not pretty but i have just started the vba.
You have to change the range back to yours
Sub format()
Dim wr1 As Range, wr2 As Range
Set wr1 = Worksheets("Sheet1").Range("a1:a10")
Set wr2 = Worksheets("Sheet2").Range("a1:a10")
For i = 1 To wr1.Count
check_value = wr1.Item(i)
For k = 1 To wr2.Count
check_value2 = wr2.Item(k)
If (check_value = check_value2) And (wr2.Item(k).Interior.ColorIndex = 33) And
(wr1.Item(i).Interior.ColorIndex = 43) Then
Else
If (check_value = check_value2) And (wr2.Item(k).Interior.ColorIndex <> 33) And
(wr1.Item(i).Interior.ColorIndex <> 43) And (wr2.Item(k).Value > "") Then
wr1.Item(i).Interior.ColorIndex = 43
wr2.Item(k).Interior.ColorIndex = 33
Exit For
End If
End If
Next
Next
MsgBox "Successfully completed"
End Sub
Hopefully you find this usefully
Your code is nearly ok, but you can save time moving ranges to arrays.
Option Explicit
Sub showDupes(src As Range, tgt As Range)
Dim c As Range, i As Long, srcVal
Dim a As Variant, found As Boolean
a = tgt.Value2 'store tgt into array for speed
For Each c In src
srcVal = c.Value2
found = False
For i = 1 To UBound(a)
If a(i, 1) = srcVal Then
found = True
Exit For
End If
Next i
If found Then
'highlight in src
c.Interior.ColorIndex = 43
'highlight in tgt
tgt.Cells(i, 1).Interior.ColorIndex = 43
End If
Next c
End Sub
Sub showDupes_test()
showDupes Sheet1.Range("B4").CurrentRegion, Sheet2.Range("b4").CurrentRegion
End Sub
Note that in this version, if tgt has local duplicates, only the first one will be highlighted.
Related
I need to be able to compare every cell in 2 worksheets but the data won't always be in the same row as new data is added and exported constantly.
Range on both sheets would be fairly large, so for now I have limited it to A1:AS150. Any instance where a match cannot be found I'd like to highlight the cell.
I have found this, which looks close to what I need but doesn't work (obviously, I have added the Else code in my working example).
Sub test()
Dim varSheetA As Variant
Dim varSheetB As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
strRangeToCheck = "A1:AS150"
' If you know the data will only be in a smaller range, reduce the size of the ranges above.
Debug.Print Now
varSheetA = Worksheets("Sheet1").Range(strRangeToCheck)
varSheetB = Worksheets("Sheet2").Range(strRangeToCheck) ' or whatever your other sheet is.
Debug.Print Now
For iRow = LBound(varSheetA, 1) To UBound(varSheetA, 1)
For iCol = LBound(varSheetA, 2) To UBound(varSheetA, 2)
If varSheetA(iRow, iCol) = varSheetB(iRow, iCol) Then
' Cells are identical.
' Do nothing.
Else
' Cells are different.
' Code goes here for whatever it is you want to do.
End If
Next iCol
Next iRow
To answer 'Foxfire And Burns And Burns' Questions:
Checks: Does Sheet1.Cell$.Value exist in sheet2 but for every cell in the range on both sheets.
Sheet1
A
B
C
Paul
999
ABC111
John
888
ABC222
Harry
777
ABC333
Tom
666
ABC444
Sheet2
A
B
C
Tom
666
ABC444
John
888
ABC222
Harry
777
ABC333
So in these examples:
Search Sheet1.A1 in Sheet 2, IF = Match Then nothing ELSE Highlight Red. Then A2, A3 etc, Then B1, B2 etc, Then C1, C2 etc...you get the gist.
You mention in your VBA code that something will need to be done, but in your example your just mean that a cell will be highlighted.
This is already covered by Excel's conditional formatting feature. You can be conditional formatting on a formula (in your case you might use a Match() function).
I would advise you to start working with a =Match() formula, in order to learn how this works (you might use =MATCH(A1,$B$1:$B$2,0) as an example, the dollarsigns are used for indicating that the lookup values are not to change), do it on different sheets and then try to get conditional formatting working, first basically and then based on your formula.
Sub test()
Dim varSheetA As Worksheet
Dim varSheetB As Worksheet
Dim i As Long
Dim LR As Long
Set varSheetA = ThisWorkbook.Worksheets("Sheet1")
Set varSheetB = ThisWorkbook.Worksheets("Sheet2")
LR = varSheetA.Range("A" & varSheetA.Rows.Count).End(xlUp).Row
For i = 1 To LR 'we start at first row of sheet 1
If Application.WorksheetFunction.CountIf(varSheetB.Range("A:A"), varSheetA.Range("A" & i).Value) = 0 Then varSheetA.Range("A" & i).Interior.Color = vbRed
Next i
'clean variables
Set varSheetA = Nothing
Set varSheetB = Nothing
End Sub
The code will count each single cell value from column A from Sheet 1 and will check if it exists somewhere in column A in Sheet 2. If not, then highligh in red.
Output after executing code with the data example you've posted:
UPDATE": I made a fakedataset. Notice row Captain America. Values from columns A and C are same in both sheets, but different on column B
Sub test()
Dim varSheetA As Worksheet
Dim varSheetB As Worksheet
Dim i As Long
Dim LR As Long
Dim MyPos As Long
Set varSheetA = ThisWorkbook.Worksheets("Sheet1")
Set varSheetB = ThisWorkbook.Worksheets("Sheet2")
LR = varSheetA.Range("A" & varSheetA.Rows.Count).End(xlUp).Row
For i = 1 To LR 'we start at first row of sheet 1
If Application.WorksheetFunction.CountIf(varSheetB.Range("C:C"), varSheetA.Range("C" & i).Value) > 0 Then
'Match found on Column C. Check A and B
MyPos = Application.WorksheetFunction.Match(varSheetA.Range("C" & i).Value, varSheetB.Range("C:C"), 0)
If varSheetA.Range("A" & i).Value <> varSheetB.Range("A" & MyPost.Value Then varSheetA.Range("A" & i).Interior.Color = vbRed
If varSheetA.Range("B" & i).Value <> varSheetB.Range("B" & MyPos).Value Then varSheetA.Range("B" & i).Interior.Color = vbRed
End If
Next i
'clean variables
Set varSheetA = Nothing
Set varSheetB = Nothing
End Sub
Output:
That cell has been highlighet because is different.
Please, note this code will work only if all values in column C are unique.
Here is my code:
Option Explicit
Private Const SHEET_1 As String = "Sheet1"
Private Const SHEET_2 As String = "Sheet2"
Private Const FIRST_CELL As String = "A1"
Private Const MAX_ROWS As Long = 1048576
Private Const MAX_COLUMNS As Long = 16384
Private varSheetA As Worksheet
Private varSheetB As Worksheet
Private last_row As Long
Private last_column As Long
Private sheet1_row As Long
Private sheet1_column As Long
Private sheet2_row As Long
Private row_match As Boolean
Public Sub CompareTables()
Set varSheetA = ThisWorkbook.Worksheets(SHEET_1)
Set varSheetB = ThisWorkbook.Worksheets(SHEET_2)
'Gets the real Table size
For sheet1_row = 1 To MAX_ROWS - 1
If varSheetA.Range(FIRST_CELL).Offset(sheet1_row, 0).Value = vbNullString _
And varSheetB.Range(FIRST_CELL).Offset(sheet1_row, 0).Value = vbNullString Then
last_row = sheet1_row
Exit For
End If
Next
For sheet1_column = 1 To MAX_ROWS - 1
If varSheetA.Range(FIRST_CELL).Offset(0, sheet1_column).Value = vbNullString _
And varSheetB.Range(FIRST_CELL).Offset(0, sheet1_column).Value = vbNullString Then
last_column = sheet1_column
Exit For
End If
Next
'Sets color RED by default on both Tables
Call SetTextRed(varSheetA.Range(FIRST_CELL).Resize(last_row, last_column))
Call SetTextRed(varSheetB.Range(FIRST_CELL).Resize(last_row, last_column))
'Sweeps all existing ROWS on Sheet1
For sheet1_row = 1 To last_row
'Sweeps all existing ROWS on Sheet2
For sheet2_row = 1 To last_row
row_match = True
'Sweeps all existing COLUMNS on Sheet1 and Sheet2
For sheet1_column = 1 To last_column
If varSheetA.Range(FIRST_CELL).Offset(sheet1_row - 1, sheet1_column - 1).Value _
<> varSheetB.Range(FIRST_CELL).Offset(sheet2_row - 1, sheet1_column - 1).Value Then
row_match = False
Exit For
End If
Next
If row_match Then Exit For 'Found and entire match, no need to search more
Next
'Formats as Grren whenever is a Match
If row_match Then
Call SetTextGreen(varSheetA.Range(FIRST_CELL).Offset(sheet1_row - 1, 0).Resize(1, last_column))
Call SetTextGreen(varSheetB.Range(FIRST_CELL).Offset(sheet2_row - 1, 0).Resize(1, last_column))
End If
Next
End Sub
'Sub Function that sets entire row text as RED
Private Sub SetTextRed(ByVal entireRow As Range)
With entireRow.Font
.Color = RGB(255, 0, 0)
.TintAndShade = 0
End With
End Sub
'Sub Function that sets entire row text as GREEN
Private Sub SetTextGreen(ByVal entireRow As Range)
With entireRow.Font
.Color = RGB(0, 255, 0)
.TintAndShade = 0
End With
End Sub
Looking for assistance with the following:
Goal:
Compare cells in 2 defined ranges (same size) one by one. If they are the same then move on to the next set of cells. If not:
Input an integer (between 1 to 2000) in a corresponding cell within a 3rd range (same size as the other 2). Run this in a For loop until the cells in the first 2 ranges equal each other.
Once achieved, then move on to the next set of cells and so forth.
The code I've written up so far is outlined below but its not producing the right results. From what I can tell, the hCell value loops while the rest don't which is putting the If comparison conditions off...
Thank you for any help with this!
Sub Update()
Range("A1").Select
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
Sheets("Funds").Select
Range("A1").Select
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
'resets the "looping cells" from NR8 to PF207.
'Dim d As Integer
For d = 8 To 207
Range(Cells(d, 382), Cells(d, 422)) = ""
Next
Dim e As Integer
e = 1
Dim fRng As Range: Set fRng = Range("RB8:SP207")
Dim fCell As Range
Dim gRng As Range: Set gRng = Range("SU8:UI207")
Dim gCell As Range
Dim hRng As Range: Set hRng = Range("NR8:PF207")
Dim hCell As Range
Dim i As Integer
i = i
For e = 8 To 207
For Each fCell In fRng.Cells
For Each gCell In gRng.Cells
For Each hCell In hRng.Cells
If Cells(e, 191).Value = 0 Then
Exit For
Else
If (fCell.Value >= gCell.Value Or gCell.Value = "N/A") Then
Exit For
Else
For i = 0 To 2000
If fCell.Value >= gCell.Value Then
Exit For
Else
hCell.Value = i
If fCell.Value >= gCell.Value Then
Exit For
End If
End If
Next i
End If
End If
Next hCell, gCell, fCell
End If
Next e
Range("A1").Select
End Sub
I assume the values in the first two ranges are in some way dependent on the values in the third.
Option Explicit
Sub Update()
Const NCOLS = 41 ' 41
Const NROWS = 200 ' 200
Const LOOPMAX = 2000 ' 2000
Dim wb As Workbook, ws As Worksheet
Dim rng1 As Range, rng2 As Range, rng3 As Range
Dim cell1 As Range, cell2 As Range
Dim i As Long, r As Long, c As Integer, t0 As Double
t0 = Timer
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
Set rng1 = ws.Range("RB8")
Set rng2 = ws.Range("SU8")
Set rng3 = ws.Range("NR8")
'resets NR8 to PF207.
rng3.Resize(NROWS, NCOLS).Value = ""
Application.ScreenUpdating = False
For r = 1 To NROWS
Application.StatusBar = "Row " & r & " of " & NROWS
For c = 1 To NCOLS
Set cell1 = rng1.Offset(r - 1, c - 1)
Set cell2 = rng2.Offset(r - 1, c - 1)
If (cell1.Value <> cell2.Value) Or (cell2.Value = "N/A") Then
i = 0
Do
rng3.Offset(r - 1, c - 1) = i
i = i + 1
Loop Until cell1.Value = cell2.Value Or i > LOOPMAX
End If
Next c
Next r
Application.ScreenUpdating = True
MsgBox "Done", vbInformation, Int(Timer - t0) & " seconds"
rng3.Select
End Sub
I am working on an Excel document using VBA. This document contains a database with multiple columns, but for simplicity, let's say I have 2 columns:
Column C corresponds to names
Column F corresponds to numbers.
I'm trying to create a macro that checks all the numbers in column F (with a loop). If the number is above 100, then check the adjacent cell in column C. If the name corresponds to a condition (let's say corresponds to John or Tom), then add the value of the number in another sheet. If none of those apply, check the next cell.
My problem is that I can't find a way to define the cells in column C (Creating a variable/object to call the cells or calling directly the adjacent cell).
My code looks like this:
Sub Test1()
Dim rngnumbers, rngnames, MultipleRange As Range
Set rngnumbers = Sheet2.Range("F2:F999")
Set rngnames = Sheet2.Range("C2:C999")
Set MultipleRange = Union(rngnumbers, rngnames)
For Each numb In rngnumbers
If numb.Value >= 100 Then
If Sheet2.Range("C2") = "John" Or Sheet2.Range("C2") = "Tom" Then '''The problem here is that it only looks at the cell C2 and not the adjacent cell
Sheet1.Range("I999").End(xlUp).Offset(1, 0).Value = numb.Value
Else
End If
End If
Next numb
End Sub
I tried modifying the line:
'If Sheet2.Range("C2") = "John" Or Sheet2.Range("C2") = "Tom" Then'
to something like:
'newname.String = "John" '
But I can't find a way to define newname.
Another idea would be to increment the If statement for the names within the For loop.
Additional note:
I am also not using formulas directly within Excel as I don't want any blank cells or zeros when the if functions are False.
Does this solve your problem - referencing the relevant cell in column C? OFFSET provides a relative reference, in this case look 3 columns to the left of F.
Sub Test1()
Dim rngnumbers As Range, rngnames As Range, MultipleRange As Range, numb As Range
Set rngnumbers = Sheet2.Range("F2:F999")
Set rngnames = Sheet2.Range("C2:C999")
Set MultipleRange = Union(rngnumbers, rngnames)
For Each numb In rngnumbers
If numb.Value >= 100 Then
If numb.Offset(, -3) = "John" Or numb.Offset(, -3) = "Tom" Then
Sheet1.Range("I999").End(xlUp).Offset(1, 0).Value = numb.Value
End If
End If
Next numb
End Sub
Have you considered SUMIFS instead?
You want something like this?
Sub Test1()
Dim lRow As Long, r As Long
lRow = 1000 'last row in your data
Dim ws As Worksheet
Set ws = Worksheets("List with your data")
For i = 2 To lRow
If ws.Range("F" & i) > 100 Then
If ws.Range("C" & i).Value = "John" Or ws.Range("C" & i).Value = "Tom" Then
Worksheets("Another sheet sheet").Range("A" & r) = Range("C" & i).Value ' r - Row, where we want to enter uor text
r = r + 1 'if you want to put next name on the next row
End If
End If
Next
End Sub
Two Ifs in a Loop
Union Version
Option Explicit
Sub Test1()
Const cFirst As Integer = 2
Const cLast As Integer = 999
Const cCol1 As Variant = "F"
Const cCol2 As Variant = "C"
Const cCol3 As Variant = "I"
Dim i As Integer
Dim rngU As Range
With Sheet2
For i = cFirst To cLast
If IsNumeric(.Cells(i, cCol1)) And .Cells(i, cCol1) >= 100 Then
If .Cells(i, cCol2) = "John" _
Or .Cells(i, cCol2) = "Tom" Then
If Not rngU Is Nothing Then
Set rngU = Union(rngU, .Cells(i, cCol1))
Else
Set rngU = .Cells(i, cCol1)
End If
End If
End If
Next
End With
If Not rngU Is Nothing Then
rngU.Copy Sheet1.Cells(cLast, cCol3).End(xlUp).Offset(1, 0)
Set rngU = Nothing
End If
End Sub
I normally work with arrays:
Sub Test1()
Dim rngnumbers As Excel.Range
Dim arrVals As variant
Dim lngRow As long
Arrvals = Sheet2.Range("C2:F999").value
For Lngrow = lbound(arrvals,1) to ubound(arrvals,1)
If arrvals(lngrow,4) >= 100 Then
If arrvals(lngrow,1)= "John" Or arrvals(lngrow,1) = "Tom" Then '''The problem here is that it only looks at the cell C2 and not the adjacent cell
Sheet1.Range("I999").End(xlUp).Offset(1, 0).Value = arrvals(lngrow,4)
Else
End If
End If
Next lngrow
End Sub
Actually I would probably build an output array as well, but my thumb is tired...
This is my first post and I'm kind of a beginner; please be gentle. See this link for a reference of the sheet I'm working with.
My plan is to have B2 contain a drop-down list that will be used to selectively collapse certain row groups to just their heading. I've figured out how to collapse one group with this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("B1")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If Range("B1") = "All" Then
Rows("3:6").Select
Selection.EntireRow.Hidden = False
Range("B1").Select
Else
Rows("3:6").Select
Selection.EntireRow.Hidden = True
Range("B1").Select
End If
End If
End Sub
What I don't have is a way to automatically find the groups. If I use a range like Rows("3:6") and someone adds/removes a row, it won't work. (right?)
What I think I need is a way to identify the required ranges by looking at information in the headers. The reference example is blank, but at the "A" column of each grey row will be a number (100, 101, 150, 380, 420A, 420B, 420C, 890). No number will appear twice, and they will appear in numerical order. The "A" column in the white cells under the gray headers will all be blank.
Is there VBA code that will find the locations of the unique headers so I can use their locations to collapse specific groups?
Additional edit to add new screenshots of what I'm hoping to achieve. Person X, Y, Z all have their predetermined grouping they want expanded or collapsed. And I'd probably add an "all" and "none" if I can figure it out. They'll give me that in advance. The numbers on the left won't ever change. It's only a question of whether Person X wants group 120 expanded or collapsed. https://imgur.com/c2lNujn
Edit to show current code:
Public HeaderColor As Long
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Me.HeaderColor = RGB(217, 217, 217)
'If A1 is true, group rows
If Range("A1").Value Then
'Use getRegion function on target
Dim rng As Range
Set rng = getRegion(Target)
'If the returned range is nothing then end sub
If rng Is Nothing Then Exit Sub
'Select region
Application.EnableEvents = False
rng.Select
Application.EnableEvents = True
End If
'If D1 is true, apply Y/N options for selection in C1
If Range("D1").Value Then
Dim rngX As Range, c As Range
Set rngX = Worksheets("Options").Range("A1:N1").Find(Range("C1"), lookat:=xlPart)
If Not rngX Is Nothing Then
'MsgBox Chr(34) & Range("C1").Value & Chr(34) & " found at " & rngX.Address
End If
'Check
' Dim groupcounter As Long
' For groupcounter = 1 To 80
' If Worksheets("Options").Range(rngX.Column, groupcounter + 1) = "Y" Then
' getNthRegion(ActiveSheet, groupcounter).Hidden = True
' ElseIf Worksheets("Options").Range(rng.Column, groupcounter + 1) = "N" Then
' getNthRegion(ActiveSheet, groupcounter).Hidden = False
' End If
' Next groupcounter
End If
End Sub
Sub customiseVisibility(ByVal query As String)
Dim cell As Range
Set cell = OptionsSheet.Range("1:1").Find(query)
Dim offset As Long
offset = 1
While Not IsEmpty(cell.offset(offset))
getNthRegion(MySheet, offset).Hidden = cell.offset(offset).Value = "N"
offset = offset + 1
Wend
End Sub
Private Function getRegion(cell As Range) As Range
Dim formatted As Boolean
Dim cell_start, cell_end As Range
'If cell row is 1 then exit function
If cell.Row <= 1 Then Exit Function
'If cell row count > 1 then use first cell selected
If cell.Rows.Count > 1 Then Set cell = cell.Cells(1, 1)
'If selection is outside of used range, do nothing
If Application.Intersect(cell, cell.Parent.UsedRange) Is Nothing Then Exit Function
'Special condition
If cell.Interior.Color = Me.HeaderColor Then
'Select row below
Set cell = cell.offset(1)
End If
'Get start cell
Set cell_start = cell
While Not cell_start.Interior.Color = Me.HeaderColor And Not Application.Intersect(cell_start, cell.Parent.UsedRange) Is Nothing ' Your gray color
Set cell_start = cell_start.offset(-1)
Wend
'Get end cell
Set cell_end = cell
While Not cell_end.offset(iRowEnd, 0).Interior.Color = Me.HeaderColor And Not Application.Intersect(cell_end, cell.Parent.UsedRange) Is Nothing ' Your gray color
Set cell_end = cell_end.offset(1)
Wend
'Get region
Set getRegion = Range(cell_start.offset(1), cell_end.offset(-1)).EntireRow
End Function
Function getNthRegion(ByVal sheet As Worksheet, ByVal n As Long) As Range
Dim i, counter As Long
For i = 1 To sheet.UsedRange.Rows.Count
If sheet.Cells(i, 1).Interior.Color = HeaderColor Then
counter = counter + 1
End If
If counter = n Then
Set getNthRegion = getRegion(sheet.Cells(i, 1))
Exit Function
End If
Next
End Function
Could you abuse your formatting?
Here is tested code:
Public HeaderColor as Long
Private OptionsSheet as Worksheet
Private DataSheet as Worksheet
Private Sub Worksheet_Change(ByVal Target As Range)
Me.HeaderColor = RGB(217, 217, 217)
set OptionsSheet = sheets("Options")
set DataSheet = ActiveWorksheet
if target.address = "$B$1" then
customiseVisibility target.value
end if
End Sub
Sub customiseVisibility(ByVal query As String)
Dim cell As Range
Set cell = OptionsSheet.Range("1:1").Find(query)
Dim offset As Long
offset = 1
While Not IsEmpty(cell.offset(offset))
getNthRegion(DataSheet, offset).Hidden = cell.offset(offset).Value = "N"
offset = offset + 1
Wend
End Sub
Private Function getRegion(cell As Range) As Range
Dim formatted As Boolean
Dim cell_start, cell_end As Range
'If cell row is 1 then exit function
If cell.Row <= 1 Then Exit Function
'If cell row count > 1 then use first cell selected
If cell.Rows.Count > 1 Then Set cell = cell.Cells(1, 1)
'If selection is outside of used range, do nothing
If Application.Intersect(cell, cell.Parent.UsedRange) Is Nothing Then Exit Function
'Special condition
If cell.Interior.Color = Me.HeaderColor Then
'Select row below
Set cell = cell.offset(1)
End If
'Get start cell
Set cell_start = cell
While Not cell_start.Interior.Color = Me.HeaderColor And Not Application.Intersect(cell_start, cell.Parent.UsedRange) Is Nothing ' Your gray color
Set cell_start = cell_start.offset(-1)
Wend
'Get end cell
Set cell_end = cell
While Not cell_end.offset(iRowEnd, 0).Interior.Color = Me.HeaderColor And Not Application.Intersect(cell_end, cell.Parent.UsedRange) Is Nothing ' Your gray color
Set cell_end = cell_end.offset(1)
Wend
'Get region
Set getRegion = Range(cell_start.offset(1), cell_end.offset(-1)).EntireRow
End Function
Function getNthRegion(ByVal sheet As Worksheet, ByVal n As Long) As Range
Dim i, counter As Long
For i = 1 To sheet.UsedRange.Rows.Count
If sheet.Cells(i, 1).Interior.Color = HeaderColor Then
counter = counter + 1
End If
If counter = n Then
Set getNthRegion = getRegion(sheet.Cells(i, 1))
Exit Function
End If
Next
End Function
Note:
This question is really really specific. Next time try to break your problem down into smaller chunks and take on 1 question at a time (if anything). Also I strongly recommend including example data to work off of. E.G.
| Number | All | PersonA | PersonB | ...
-----------------------------------------
| 1 | N | Y | N | ...
| 2 | N | Y | N | ...
| 3 | N | Y | N | ...
| 4 | N | Y | Y | ...
| 5 | N | N | N | ...
| 6 | N | N | Y | ...
| 7 | N | N | N | ...
| 8 | N | N | Y | ...
As #BigBen suggested - use FIND and then Group between the headers - one row down from Start and one row up from End.
Public Sub CreateOutline()
Dim sFirstAdd As String
Dim rFound As Range
Dim rStart As Range
Dim rEnd As Range
With ThisWorkbook.Worksheets("Sheet1")
.Cells.ClearOutline 'Remove any existing.
With .Cells.EntireColumn
Set rFound = .Find(What:="*", _
After:=.Cells(1, 1), _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext)
If Not rFound Is Nothing Then
sFirstAdd = rFound.Address
Do
Set rStart = rFound
Set rFound = .FindNext(rFound)
Set rEnd = rFound
Range(rStart.Offset(1), rEnd.Offset(-1)).Rows.Group
'Include a marker to state where the end of the last section is.
'Otherwise the last section will go from cell A1 to just below last section header.
If rEnd = "End" Then sFirstAdd = rFound.Address
Loop While rFound.Address <> sFirstAdd
End If
End With
End With
End Sub
Instead of hiding and unhiding rows, you can use the Outline.ShowLevels method to collapse the grouping.
So something like this to:
Test if B1 changed.
Find the corresponding header in the first column.
If there's a match, test if the next row has a grouping (OutlineLevel > 1).
If so, ShowDetail = False for that row.
Note that the use of On Error Resume Next is discouraged. However .ShowDetail = False threw an error when the specified group was already collapsed. As I investigate further, this is the quick fix.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Me.Range("B1"), Target) Is Nothing Then
With Me
Dim rng As Range
Set rng = .Columns(1).Find(.Range("B1").Value)
If Not rng Is Nothing Then
With rng.Offset(1).EntireRow
On Error Resume Next
If .OutlineLevel > 1 Then .ShowDetail = False
End With
End If
End With
End If
End Sub
I want to unhide a single row if an ENTIRE range of rows is hidden. I want to hide this row if even a SINGLE row within the range is unhidden. What is the syntax for this? My current code is as follows:
Public Sub MySub()
Application.ScreenUpdating = False
With Range("A1:A5")
.EntireRow.Hidden = False
For Each cell In Range("A1:A5")
Select Case cell.Value
Case Is = "-"
cell.EntireRow.Hidden = True
End Select
Next cell
End With
Application.ScreenUpdating = True
End Sub
I think I understand. How's this:
Sub test()
Dim cel As Range, rng As Range
Dim hideRow&, numDashes&
Set rng = Range("A1:A5")
hideRow = rng.Count + 1
For Each cel In rng
If cel.Value = "-" Then
numDashes = numDashes + 1
Rows(cel.Row).EntireRow.Hidden = True
End If
Next cel
If numDashes = rng.Count Then
' If all cells in the range are '-'
Rows(hideRow).EntireRow.Hidden = False
Else
Rows(hideRow).EntireRow.Hidden = True
End If
End Sub
I'm kind of assuming that you want to hide/unhide Row 6, since it's one below your range's last row. Therefore, I created a variable to hold this. This way, if you want to change your range to say A1:A100, all you have to do is adjust the rng, and it'll look to hide/unhide row 101. Of course, if you just need it to be 6, then just do hideRow = 6.
Edit: For fun, I tried to reduce the use of the counting variable numDashes and tried to the part where you check your range for all - to be more concise. The below should work too, but might need a tweak or two:
Sub test2()
Dim cel As Range, rng As Range
Dim hideRow&
Set rng = Range("A1:A5")
hideRow = rng.Count + 1
'Check to see if your range is entirely made up of `-`
If WorksheetFunction.CountIf(rng, "-") = rng.Count Then
Rows(hideRow).EntireRow.Hidden = False
' If you want to stop your macro if ALL range values are "-", then uncomment the next line:
'Exit Sub
Else
Rows(hideRow).EntireRow.Hidden = True
End If
For Each cel In rng
If cel.Value = "-" Then
Rows(cel.Row).EntireRow.Hidden = True
End If
Next cel
End Sub
You can do this with a formula in a helper column. I used this one for financial statements to suppress rows where multiple column are all zero to shorten up the report.
=IF(AND(SUM(A7:R7)<1,SUM(A7:R7)>-1),IF(OR(ISNUMBER(LEFT(H7,4)),ISBLANK(H7),ISERR(VALUE(LEFT(H7,4)))),"Show","Hide"),"Show").
Then filter the rows by that column.