Amend VBA Code to look at cell value

hrayani

Well-known Member
Joined
Jul 23, 2010
Messages
1,475
Office Version
  1. 2016
Platform
  1. Windows
Hello Friends,

I am using these below 2 vba codes for content banding

Code 1 for content banding with colors
At this point the code is working fine as it is banding content when a value changes in column # 6
How to tell the code that
1) If Range("C1").value = "customer" then look at column # 6
2) If Range("C1").value = "supplier" then look at column # 7
VBA Code:
Sub content_banding()

Application.ScreenUpdating = False
Dim r As Long, val As String, c As Long

Range("B4:N1000").Interior.Color = xlNone

    r = 6
    val = ActiveSheet.Cells(r, 6).Value
  
    For r = 4 To ActiveSheet.Rows.Count
        If IsEmpty(ActiveSheet.Cells(r, 6).Value) Then
            Exit For
        End If

        If ActiveSheet.Cells(r, 6).Value <> val Then
            If c = 20 Then
                c = 19
              
            Else
                c = 20
            End If
        End If

       ActiveSheet.Range("C" & r & ":N" & r).Select
        With Selection.Interior
            .ColorIndex = c
            .Pattern = xlSolid
            .TintAndShade = 0.5
            End With

        val = ActiveSheet.Cells(r, 6).Value
    Next
  
    Application.ScreenUpdating = False
End Sub

Code 2 for content banding with border
At this point the code is working fine as it is banding content when a value changes in column # 6
How to tell the code that
1) If Range("C1").value = "customer" then look at column # 6
2) If Range("C1").value = "supplier" then look at column # 7

VBA Code:
Sub horizontal_broders()
 Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim rng As Range
  
    For Each rng In Range("F4:F" & LastRow)
  
        If rng <> rng.Offset(1, 0) Then
            Range("C" & rng.Row & ":N" & rng.Row).Borders(xlEdgeBottom).LineStyle = xlContinuous
            Range("C" & rng.Row & ":N" & rng.Row).Borders(xlEdgeBottom).Weight = xlMedium
     
        End If
        Next rng
End Sub
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
Try this revised code
VBA Code:
Sub content_banding()

Application.ScreenUpdating = False
Dim r As Long, val As String, c As Long, clm As Long

Range("B4:N1000").Interior.Color = xlNone

If Range("C1").Value = "customer" Then
clm = 6
ElseIf Range("C1").Value = "supplier" Then
clm = 7
End If
    r = 6
    val = ActiveSheet.Cells(r, clm).Value
  
    For r = 4 To ActiveSheet.Rows.Count
        If IsEmpty(ActiveSheet.Cells(r, clm).Value) Then
            Exit For
        End If

        If ActiveSheet.Cells(r, clm).Value <> val Then
            If c = 20 Then
                c = 19
              
            Else
                c = 20
            End If
        End If

       ActiveSheet.Range("C" & r & ":N" & r).Select
        With Selection.Interior
            .ColorIndex = c
            .Pattern = xlSolid
            .TintAndShade = 0.5
            End With

        val = ActiveSheet.Cells(r, clm).Value
    Next
  
    Application.ScreenUpdating = False
End Sub
 
Upvote 0
Try this revised code
VBA Code:
Sub content_banding()

Application.ScreenUpdating = False
Dim r As Long, val As String, c As Long, clm As Long

Range("B4:N1000").Interior.Color = xlNone

If Range("C1").Value = "customer" Then
clm = 6
ElseIf Range("C1").Value = "supplier" Then
clm = 7
End If
    r = 6
    val = ActiveSheet.Cells(r, clm).Value
 
    For r = 4 To ActiveSheet.Rows.Count
        If IsEmpty(ActiveSheet.Cells(r, clm).Value) Then
            Exit For
        End If

        If ActiveSheet.Cells(r, clm).Value <> val Then
            If c = 20 Then
                c = 19
             
            Else
                c = 20
            End If
        End If

       ActiveSheet.Range("C" & r & ":N" & r).Select
        With Selection.Interior
            .ColorIndex = c
            .Pattern = xlSolid
            .TintAndShade = 0.5
            End With

        val = ActiveSheet.Cells(r, clm).Value
    Next
 
    Application.ScreenUpdating = False
End Sub
Thanks for the repy

It works but it does not band on the first change.
It starts banding from the 2nd change

Any idea ??
 
Upvote 0

Forum statistics

Threads
1,213,527
Messages
6,114,150
Members
448,552
Latest member
WORKINGWITHNOLEADER

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