Creating Loop for Entire Used Range across all sheets

[HSAR]

Hi, Team Mrexcel i am new here.

I have been using this below code to count colored cell right now this is just counting colored cell for single column. If i add two or more ranges then its answer would be same rather then different.

I want you to modify this code so that code will count all used range. For Example if it is count Column "J" then result should be mentioned in J1 & if it is count Column "K" then result should be mentioned in K1
and so on till used range.

I am not expecting for formula created by VBA. Please do help.

Public Sub CountColorCells()
 Dim rng As Range
 Dim lColorCounter As Long
 Dim rngCell As Range
 Set rng = Sheet2.Range("J2:J20")
 For Each rngCell In rng
 If Cells(rngCell.Row, rngCell.Column).DisplayFormat.Interior.Color = RGB(183, 225, 205) Then
 lColorCounter = lColorCounter + 1
 End If
 Next
 Sheet2.Range("J1") = lColorCounter
End Sub

 

[mumps]

This macro requires that the cells in each column with data have a header in row 1. The header can be anything because it will be replaced with the count of colored cells in that column. It also assumes that all the colored cells have data in them.

Public Sub CountColorCells()
    Application.ScreenUpdating = False
    Dim LastRow As Long, lCol As Long, x As Long
    lCol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    For x = 1 To lCol
        LastRow = Columns(x).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Range(Cells(1, 1), Cells(LastRow, lCol)).AutoFilter Field:=x, Criteria1:=RGB(183, 225, 205), Operator:=xlFilterCellColor
        Cells(1, x) = [subtotal(103,A:A)] - 1
        Range("A1").AutoFilter
    Next x
    Application.ScreenUpdating = True
End Sub

 

[HSAR]

Thank you for explaining it very well i would request in this regard if value is must to mention in colored cell then please modify the below code.

which automatically mention the count of "Complete" and "Incomplete" in row 1 and 2 across all sheets.

That way colored cell count won't be required because we would have values in colored cell Complete and incomplete.

Sub put_text_based_on_cell_color()
Dim f As Range, cell As String, r As Range, i As Long
Dim Arr As Variant
Application.ScreenUpdating = False
' (row initial, col initial), (row end, col end)
Set R = Range("A3", ActiveSheet.UsedRange)
Arr = Array(RGB(244, 204, 204), "Incomplete", RGB(183, 225, 205),
"Complete")
For i = 0 To UBound(Arr) Step 2
Application.FindFormat.Interior.Color = Arr(i)
Set f = r.Find("", r.Cells(1, 1), xlValues, xlWhole, xlByRows, xlNext, False, SearchFormat:=True)
If Not f Is Nothing Then
cell = f.Address
Do
f.Value = Arr(i + 1)
Set f = r.Find("", f, xlValues, xlWhole, xlByRows, xlNext, False, SearchFormat:=True)
Loop While f.Address <> cell
End If
Application.FindFormat.Clear
Next
End Sub

 

[HSAR]

So i have made this by my own using Record Macro.

But i also want that this code should be applicable on all sheets opened in workbook.

Sub CopyPasting()
'
' CopyPasting Macro
'
Dim f As Range, cell As String, r As Range, i As Long
  Dim Arr As Variant
  Application.ScreenUpdating = False
 
  '                  (row initial, col initial),   (row end, col end)
Set r = Range("A3", ActiveSheet.UsedRange)
  Arr = Array(RGB(244, 204, 204), "Incomplete", RGB(244, 199, 195), "Incomplete", RGB(183, 225, 205), "Complete")
 
  For i = 0 To UBound(Arr) Step 2
    Application.FindFormat.Interior.Color = Arr(i)
    Set f = r.Find("", r.Cells(1, 1), xlValues, xlWhole, xlByRows, xlNext, False, SearchFormat:=True)
    If Not f Is Nothing Then
    cell = f.Address
    Do
      f.Value = Arr(i + 1)
      Set f = r.Find("", f, xlValues, xlWhole, xlByRows, xlNext, False, SearchFormat:=True)
    Loop While f.Address <> cell
    End If
    Application.FindFormat.Clear
  Next

  Range("A1:A2").EntireRow.Insert
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=COUNTIF(R[3]C:R[1048575]C,""Incomplete"")"
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "=COUNTIF(R[2]C:R[1048574]C,""Complete"")"
    Range("A1:A2").Select
    
    Selection.AutoFill Destination:=Range("A1:AC2"), Type:=xlFillDefault


End Sub

 

[HSAR]

Looking for help.

 

[HSAR]

@DanteAmor

Sir please also help me in this second last comment.

 

[mumps]

Please upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Include a detailed explanation of what you would like to do referring to specific cells, rows, columns and worksheets. If the workbook contains confidential information, you could replace it with generic data.

 

[DanteAmor]

Try this

Sub CopyPasting()
  '
  ' CopyPasting Macro
  '
  Dim f As Range, cell As String, r As Range, i As Long
  Dim Arr As Variant, sh As Worksheet
  
  Application.ScreenUpdating = False
  
  For Each sh In Sheets
    sh.Select
    '                  (row initial, col initial),   (row end, col end)
    Set r = Range("A3", ActiveSheet.UsedRange)
    Arr = Array(RGB(244, 204, 204), "Incomplete", RGB(244, 199, 195), "Incomplete", RGB(183, 225, 205), "Complete")
    
    For i = 0 To UBound(Arr) Step 2
      Application.FindFormat.Interior.Color = Arr(i)
      Set f = r.Find("", r.Cells(1, 1), xlValues, xlWhole, xlByRows, xlNext, False, SearchFormat:=True)
      If Not f Is Nothing Then
      cell = f.Address
      
      Do
        f.Value = Arr(i + 1)
        Set f = r.Find("", f, xlValues, xlWhole, xlByRows, xlNext, False, SearchFormat:=True)
      Loop While f.Address <> cell
      End If
      Application.FindFormat.Clear
      
    Next i
    
    Range("A1:A2").EntireRow.Insert
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=COUNTIF(R[3]C:R[1048575]C,""Incomplete"")"
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "=COUNTIF(R[2]C:R[1048574]C,""Complete"")"
    Range("A1:A2").Select
    Selection.AutoFill Destination:=Range("A1:AC2"), Type:=xlFillDefault
    
  Next sh
End Sub

 

[HSAR]

DanteAmor

You are really a great man thank you again for this favor.

 

[HSAR]

mumps

Thank you for your time and apologies if i was unable to explain you what i want.