Macro to find and count between tabs based on highlighted color

[bergy32204]

Hello.

I am pretty new to macros and have only done extremely simple stuff up to this point. The macro I am looking to make/obtain would be based on this. Also to note, I am using (version 16.84). I think the correct term is also worksheet, but I call them tabs here.



Tab 1 (main page):

From A1 down to A_ (you can enter a new item and it would automatically search/find or a button would be needed) you would essentially have the item you were looking for and it would search between all the tabs, count up all of the cells that contain that item and are highlighted green or yellow (if the highlighting cannot be done, what is an alternate way to determine to is 'green', 'yellow', or nothing), and count the amount that contain green. So for example:



A5 = iPhone 10

B5 = 10

C5 = 3

The amount of cells that contain 'iPhone 10' between all of the tabs is 15, but only 7 are highlighted yellow and 3 are green. This would in turn add green and yellow highlighted cells with that item and add that in the 'B' column (in this example, 7+3=10). Then in the 'C' column it would only count the cells with that item that are green (in this case C5 = 3).



As mentioned, this is what it should look like in the end:

I A I B I C I

4 iPhone 9 11 8 (20 total cells, 8 are highlighted green, 3 are highlighted yellow)

__________________________

5 iPhone X 5 4

__________________________

6 iPhone 11 25 11

__________________________



Hopefully this all makes sense. If you have any question please ask! Thank you very much!

 

[Jeffrey Mahoney]

I really hope this is what you wanted. In my sheet I created a named range for Cell A1 called "ItemHdr". I tested it on my end.

Book3
	A	B	C	D	E
1	Item	Green	Yellow	No Fill	Pink
2	iPhone 10	0	1	0	1
3	iPhone 8	1	0	1	0
Sheet3

Sub FindItemsByColor()
  Dim Cel As Range
  Dim Rng As Range
  Dim Sht As Worksheet
  Dim tSht As Worksheet
  Dim ByColor() As Long
  Dim ByItem() As String
  Dim ByCount() As Long
  Dim ClrCnt As Long
  Dim ItmCnt As Long
  Dim ItemHdr As Range
  Dim X As Long
  Dim Y As Long
  Dim LastCell As Range
  Dim FoundClr As Boolean
  Dim FoundItm As Boolean
  
  Set tSht = ActiveSheet
  Set ItemHdr = tSht.Range("ItemHdr")
  If ItemHdr Is Nothing Then Exit Sub
  
      'Get Colors
  Set Rng = Range(ItemHdr.Offset(0, 1), Cells(ItemHdr.Row, Cells.Columns.Count).End(xlToLeft))
  ClrCnt = Rng.Columns.Count
  ReDim ByColor(0 To ClrCnt)    'Zero is for other colors not included
  X = 0
  For Each Cel In Rng
    X = X + 1
    ByColor(X) = Cel.Interior.Color
  Next Cel
  
      'Get Items
  Set Rng = Range(ItemHdr.Offset(1, 0), Cells(Cells.Rows.Count, ItemHdr.Column).End(xlUp))
  ItmCnt = Rng.Rows.Count
  ReDim ByItem(1 To ItmCnt)
  Y = 0
  For Each Cel In Rng
    Y = Y + 1
    ByItem(Y) = Cel.Value
  Next Cel
  
  ReDim ByCount(1 To ItmCnt, 0 To ClrCnt)                         'Save the count of each item and color
  
  For Each Sht In ThisWorkbook.Worksheets
    If Sht.Name <> tSht.Name Then                                   'All other sheets except this one
      Set LastCell = Sht.Range("A1").SpecialCells(xlCellTypeLastCell)
      For Each Cel In Sht.Range(Sht.Range("A1"), LastCell)                'Look through used range
        FoundItm = False
        For X = 1 To ItmCnt                                       'Find item first
          If Cel.Value = ByItem(X) Then
            FoundItm = True
            
            FoundClr = False
            For Y = 1 To ClrCnt                                   'Find by color next
              If Cel.Interior.Color = ByColor(Y) Then
                FoundClr = True
                ByCount(X, Y) = ByCount(X, Y) + 1
              End If
              If FoundClr = True Then Exit For
            Next Y
            If FoundClr = False Then
              ByCount(X, 0) = ByCount(X, 0) + 1     'Not any provided color
            End If
            
            If FoundItm = True Then Exit For
          End If
        Next X
      Next Cel
    End If
  Next Sht
    
  Set Rng = tSht.Range(ItemHdr.Offset(1, 0), tSht.Cells(tSht.Cells.Rows.Count, ItemHdr.Column).End(xlUp))
  Y = 0
  For Each Cel In Rng
    Y = Y + 1
    For X = 1 To ClrCnt
      Cel.Offset(0, X).Value = ByCount(Y, X)
    Next X
  Next Cel
  
End Sub

 

[bergy32204]

Set ItemHdr = tSht.Range("ItemHdr")

Thank you for the help/reply.

When trying this, it gave me the error of "Run-time error '1004': Method 'Range' of object '_Worksheet" before even doing anything. I tried a few small troubleshooting things to replicate your Excel sheet, but it still did not work on my behalf. Any ideas?

 

[Jeffrey Mahoney]

Did you create that named range?

 

[bergy32204]

Did you create that named range?

I did, and I have the same output.

 

[Jeffrey Mahoney]

This part of the macro sets the range, but it mean you have to be on the sheet with the named range. I can't see whats happening on your end, so I have to ask.

Set tSht = ActiveSheet