This code needs to work on 2 worksheets

D

Darren Smith

Well-known Member
Joined
Nov 23, 2020
Messages
631
Office Version
  1. 2019
Platform
  1. Windows
I need to insert color into 2 sheets with the same command button.
How is this possible with my code?

VBA Code: 
Sub colorAbove(rng As Range)
    Dim i As Long, rrg As Range
    Dim ws As Worksheets
    
For Each ws In ThisWorkbook.Worksheets(Array("Job Card Master", "Job Card with Time Analysis"))

    For i = 1 To rng.Rows.Count
        Set rrg = rng.Rows(i)
  
        If WorksheetFunction.CountA(rrg) = 0 Then
            
            If rrg.Offset(1).Cells(3) <> "" Then
                
                rrg.Interior.ColorIndex = 36
            End If
        End If
    Next i
    Next ws
End Sub
 
Sort by date Sort by votes
Here you go

VBA Code: 
Private Sub Add_Lines_Color_And_Prices_Click()

TurnOff

    Call Delete_Color

    Dim ws As Worksheet, PartsList As Worksheet, JCM As Worksheet
    Dim Lastrow As Long, PartsListLastRow As Long, x As Long, JCMLastRow As Long
    Dim rngToCheck As Range, rng As Range, c As Range, DataRng As Range
    
    Set rngToCheck = ws.Range("A13:Q299")
    Set c = ActiveSheet.Range("E13:E299")
    Set PartsList = ThisWorkbook.Worksheets("Parts List")
    
       For Each ws In ThisWorkbook.Worksheets(Array("Job Card Master", "Job Card with Time Analysis"))

   For Each c In ws.Range("E13:E299")
    
    For Each rng In rngToCheck
     If rng.Interior.ColorIndex = 36 Then
     rng.Interior.Pattern = xlNone
     End If
    Next rng
    
    Lastrow = ws.Cells(Rows.Count, 3).End(xlUp).Row

    ws.Range("P13:P299").Value = Null
    
                If Left(c, 1) = "^" Then
                c.Font.ColorIndex = 54
                c.Font.Italic = True
                c.Font.Bold = True
                End If
                
                If Left(c, 1) = "*" Then
                c.Font.ColorIndex = 45
                c.Font.Italic = True
                c.Font.Bold = True
                End If
                
              ws.Range("P13:P299").Value = Null
    
                If Left(c, 1) = "^" Then
                c.Font.ColorIndex = 54
                c.Font.Italic = True
                c.Font.Bold = True
                End If
                
                If Left(c, 1) = "*" Then
                c.Font.ColorIndex = 45
                c.Font.Italic = True
                c.Font.Bold = True
                End If

    
     

       
                            colorAbove ws.Range("A13:Q61")
                            colorAbove ws.Range("A66:Q122")
                            colorAbove ws.Range("A127:Q183")
                            colorAbove ws.Range("A188:Q244")
                            colorAbove ws.Range("A249:Q" & Lastrow)
                           ws.Range("P13:P63").Formula = "= RoundUp(H13, 0) * O13"
                           ws.Range("P66:P122").Formula = "= RoundUp(H66, 0) * O66"
                           ws.Range("P127:P181").Formula = "= RoundUp(H127, 0) * O127"
                           ws.Range("P188:P244").Formula = "= RoundUp(H188, 0) * O188"
                           ws.Range("P249:P299").Formula = "= RoundUp(H249, 0) * O249"
                           
                           Next ws
               

                   Call Add_PartNos
    TurnOn
    
End Sub
Sub colorAbove(rng As Range)
    Dim i As Long, rrg As Range

    For i = 1 To rng.Rows.Count
        Set rrg = rng.Rows(i)
  
        If WorksheetFunction.CountA(rrg) = 0 Then
            
            If rrg.Offset(1).Cells(3) <> "" Then
                
                rrg.Interior.ColorIndex = 36
            End If
        End If
    Next i

End Sub
 
Upvote 0

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
VBA Code: 
Private Sub Add_Lines_Color_And_Prices_Click()

TurnOff

    Call Delete_Color

    Dim ws As Worksheet, PartsList As Worksheet, JCM As Worksheet
    Dim Lastrow As Long, PartsListLastRow As Long, x As Long, JCMLastRow As Long
    Dim rngToCheck As Range, rng As Range, c As Range, DataRng As Range
    
    Set rngToCheck = ws.Range("A13:Q299")
    Set c = ActiveSheet.Range("E13:E299")
    Set PartsList = ThisWorkbook.Worksheets("Parts List")
    
       For Each ws In ThisWorkbook.Worksheets(Array("Job Card Master", "Job Card with Time Analysis"))

   For Each c In ws.Range("E13:E299")
    
    For Each rng In rngToCheck
     If rng.Interior.ColorIndex = 36 Then
     rng.Interior.Pattern = xlNone
     End If
    Next rng
    
    Lastrow = ws.Cells(Rows.Count, 3).End(xlUp).Row

    ws.Range("P13:P299").Value = Null
    
                If Left(c, 1) = "^" Then
                c.Font.ColorIndex = 54
                c.Font.Italic = True
                c.Font.Bold = True
                End If
                
                If Left(c, 1) = "*" Then
                c.Font.ColorIndex = 45
                c.Font.Italic = True
                c.Font.Bold = True
                End If
                
              ws.Range("P13:P299").Value = Null
    
                If Left(c, 1) = "^" Then
                c.Font.ColorIndex = 54
                c.Font.Italic = True
                c.Font.Bold = True
                End If
                
                If Left(c, 1) = "*" Then
                c.Font.ColorIndex = 45
                c.Font.Italic = True
                c.Font.Bold = True
                End If

    
     

       
                            colorAbove ws.Range("A13:Q61")
                            colorAbove ws.Range("A66:Q122")
                            colorAbove ws.Range("A127:Q183")
                            colorAbove ws.Range("A188:Q244")
                            colorAbove ws.Range("A249:Q" & Lastrow)
                           ws.Range("P13:P63").Formula = "= RoundUp(H13, 0) * O13"
                           ws.Range("P66:P122").Formula = "= RoundUp(H66, 0) * O66"
                           ws.Range("P127:P181").Formula = "= RoundUp(H127, 0) * O127"
                           ws.Range("P188:P244").Formula = "= RoundUp(H188, 0) * O188"
                           ws.Range("P249:P299").Formula = "= RoundUp(H249, 0) * O249"
                           
                           Next ws
               

                   Call Add_PartNos
    TurnOn
    
End Sub
Sub colorAbove(rng As Range)
    Dim i As Long, rrg As Range

    For i = 1 To rng.Rows.Count
        Set rrg = rng.Rows(i)
  
        If WorksheetFunction.CountA(rrg) = 0 Then
            
            If rrg.Offset(1).Cells(3) <> "" Then
                
                rrg.Interior.ColorIndex = 36
            End If
        End If
    Next i

End Sub
 
Upvote 0
You haven't closed the first loop below.

You also haven't set a value for ws, so this will cause a run-time error, and there may be other problems with your code.

Code: 
For Each c In ws.Range("E13:E299")
   
    For Each rng In rngToCheck

I'm off-air now for a day. I can take another look later over the weekend, but you may be able to get it working in the meantime. Or perhaps with someone else's help.
 
Upvote 0
@Darren Smith

VBA Code: 
Private Sub Add_Lines_Color_And_Prices_Click()
'
    Call TurnOff
'
    Call Delete_Color
'
    Dim ws As Worksheet, PartsList As Worksheet, JCM As Worksheet
    Dim Lastrow As Long, PartsListLastRow As Long, x As Long, JCMLastRow As Long
    Dim rngToCheck As Range, rng As Range, c As Range, DataRng As Range
'
'   Missing a 'Set ws = xxxx" line  '   <--------------
    Set rngToCheck = ws.Range("A13:Q299")
    Set c = ActiveSheet.Range("E13:E299")
    Set PartsList = ThisWorkbook.Worksheets("Parts List")
'
    For Each ws In ThisWorkbook.Worksheets(Array("Job Card Master", "Job Card with Time Analysis"))
        For Each c In ws.Range("E13:E299")
            For Each rng In rngToCheck
                If rng.Interior.ColorIndex = 36 Then
                    rng.Interior.Pattern = xlNone
                End If
            Next rng
'
            Lastrow = ws.Cells(Rows.Count, 3).End(xlUp).Row
'
            ws.Range("P13:P299").Value = Null   '-------------------
'                                                                   |
            If Left(c, 1) = "^" Then            '                   |
                c.Font.ColorIndex = 54          '                   |
                c.Font.Italic = True            '                   |
                c.Font.Bold = True              '                   |
            End If                              '                   |
'                                                                   |
            If Left(c, 1) = "*" Then            '                   |
                c.Font.ColorIndex = 45          '                   |
                c.Font.Italic = True            '                   |
                c.Font.Bold = True              '                   |
            End If                              '                   /\
'                                                           Duplicate Code
            ws.Range("P13:P299").Value = Null   '                   \/
'                                                                   |
            If Left(c, 1) = "^" Then            '                   |
                c.Font.ColorIndex = 54          '                   |
                c.Font.Italic = True            '                   |
                c.Font.Bold = True              '                   |
            End If                              '                   |
'                                                                   |
            If Left(c, 1) = "*" Then            '                   |
                c.Font.ColorIndex = 45          '                   |
                c.Font.Italic = True            '                   |
                c.Font.Bold = True              '                   |
            End If                              '-------------------
'
'       Missing a 'Next c' Somewhere1 or ...
            colorAbove ws.Range("A13:Q61")
            colorAbove ws.Range("A66:Q122")
            colorAbove ws.Range("A127:Q183")
            colorAbove ws.Range("A188:Q244")
            colorAbove ws.Range("A249:Q" & Lastrow)
'
'       Missing a 'Next c' Somewhere2 or ...
            ws.Range("P13:P63").Formula = "= RoundUp(H13, 0) * O13"
            ws.Range("P66:P122").Formula = "= RoundUp(H66, 0) * O66"
            ws.Range("P127:P181").Formula = "= RoundUp(H127, 0) * O127"
            ws.Range("P188:P244").Formula = "= RoundUp(H188, 0) * O188"
            ws.Range("P249:P299").Formula = "= RoundUp(H249, 0) * O249"
'       Missing a 'Next c' Somewhere3
    Next ws
'
    Call Add_PartNos
'
    Call TurnOn
End Sub
Sub colorAbove(rng As Range)
'
    Dim i As Long, rrg As Range
'
    For i = 1 To rng.Rows.Count
        Set rrg = rng.Rows(i)
'
        If WorksheetFunction.CountA(rrg) = 0 Then
            If rrg.Offset(1).Cells(3) <> "" Then
                rrg.Interior.ColorIndex = 36
            End If
        End If
    Next i
End Sub
 
Upvote 0
This c is in relation to column E so is different from the code below. I`ve Separated them is that best?
The code below refers to the whole sheet
I`ve been through the code and declared WS as worksheets
The code can`t find the ws in the worksheet array why is this??
See code below,

VBA Code: 
Private Sub Add_Lines_Color_And_Prices_Click()

    Call TurnOff

    Call Delete_Color
    
    Call Color_Lines

    Dim ws As Worksheet, wsArray As Sheets
    Dim Lastrow As Long, JCMLastRow As Long
    Dim rngToCheck As Range, rng As Range, c As Range, DataRng As Range

    Set wsArray = ThisWorkbook.Worksheets(Array(Sheet6, Sheet7))
    For Each ws In wsArray
    Set rngToCheck = ws.Range("A13:Q299")
    Set c = ws.Range("E13:E299")


        For Each c In ws.Range("E13:E299")
            For Each rng In rngToCheck
                If rng.Interior.ColorIndex = 36 Then
                    rng.Interior.Pattern = xlNone
                End If
            Next rng

            Lastrow = ws.Cells(Rows.Count, 3).End(xlUp).Row

            ws.Range("P13:P299").Value = Null
                                                                  
            If Left(c, 1) = "^" Then
                c.Font.ColorIndex = 54
                c.Font.Bold = True
            End If

            If Left(c, 1) = "*" Then
                c.Font.ColorIndex = 45
                c.Font.Bold = True
            End If
            
            Next ws
End Sub
     Private Sub Color_Lines()
     
    Call TurnOff
    Dim ws As Worksheet, wsArray As Sheets
    Dim Lastrow As Long

    Set wsArray = ThisWorkbook.Worksheets(Array(Sheet6, Sheet7))
    For Each ws In wsArray


     
     
            colorAbove ws.Range("A13:Q61")
            colorAbove ws.Range("A66:Q122")
            colorAbove ws.Range("A127:Q183")
            colorAbove ws.Range("A188:Q244")
            colorAbove ws.Range("A249:Q" & Lastrow)

            ws.Range("P13:P63").Formula = "= RoundUp(H13, 0) * O13"
            ws.Range("P66:P122").Formula = "= RoundUp(H66, 0) * O66"
            ws.Range("P127:P181").Formula = "= RoundUp(H127, 0) * O127"
            ws.Range("P188:P244").Formula = "= RoundUp(H188, 0) * O188"
            ws.Range("P249:P299").Formula = "= RoundUp(H249, 0) * O249"

    Next ws

    Call TurnOn
    
End Sub
Sub colorAbove(rng As Range)

    Dim i As Long, rrg As Range

    For i = 1 To rng.Rows.Count
        Set rrg = rng.Rows(i)

        If WorksheetFunction.CountA(rrg) = 0 Then
            If rrg.Offset(1).Cells(3) <> "" Then
                rrg.Interior.ColorIndex = 36
            End If
        End If
    Next i
End Sub
 
Upvote 0
Darren Smith said:
I`ve been through the code and declared WS as worksheets
The code can`t find the ws in the worksheet array why is this??
Click to expand...
Assuming Sheet6 and sheet7 are codenames (?) you can loop through them like this:

VBA Code: 
Dim MySheets As Variant
Dim i As Long

MySheets = Array(Sheet6, Sheet7)

For i = LBound(MySheets) To UBound(MySheets)
    With MySheets(i)
        'Do stuff with worksheet, e.g...
        MsgBox .Name
        .Range("A1").Value = "Hello"
    End With
Next i
Your Sub Add_Lines_Color_And_Prices_Click still has nested loops without a closing Next c.

Code: 
For Each c In ws.Range("E13:E299")
    For Each rng In rngToCheck
Based on your code, I am guessing you want separate loops:
Code: 
For Each c In ws.Range("E13:E299")
    'Do stuff with c
Next c

For Each rng In rngToCheck
    'Do stuff with rng
Next rng
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

G
  • Solved
Add total row with a loop
Replies
4
Views
140
gberg
G
B
  • Question
Delete "Invisible" Rows
Replies
5
Views
451
MARK858
MARK858
S
  • Solved
Error executing vba code
Replies
2
Views
79
sofas
S
C
  • Solved
Out of Memory Error 7 on text replace
Replies
6
Views
93
Candyman8019
C
Agnarr
  • Question
VBA code mix
Replies
1
Views
354
Joe4
Joe4

Forum statistics

Threads
1,214,913
Messages
6,122,207
Members
449,074
Latest member
cancansova

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top