Results 1 to 11 of 11
  1. #1
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post

    Post VBA code to apply conditional formating

    Hi Experts
    I am not sure if this is possible or not.
    I have to apply the below conditional formatting in all my reports. I am trying to create a VBA code to make this task automate.
    The Rows and columns length is dynamic
    The subtotal should be applied on the field with the word “Year” in its heading. When we click on subtotal button in excel the field At each change in Should be the header with word Year in it.
    Is it possible to find the currency in the columns and apply subtotal to it.

    Code:
    Sub Macro1()
    '
    ' Macro1 Macro
    '
     
    '
        Range("B1:E8").Select
        Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(2, 3, 4), _
            Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        Range("B1").Select
        Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
            "=ISNUMBER(FIND(""Total"",$B1))"
        Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
        With Selection.FormatConditions(1).Font
            .Color = -16727809
            .TintAndShade = 0
        End With
        With Selection.FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorLight2
            .TintAndShade = 0
        End With
        Selection.FormatConditions(1).StopIfTrue = False
    End Sub
    Please let me know your view on it.

    Regards,
    JD

  2. #2
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,436
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    JD,

    At least one sample file with a raw sheet and a formatted sheet would be useful.
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  3. #3
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post

    Post

    Hi RG
    Please find the sample file for your reference. The data will vary in the original data file.
    The year and currency column will not be at fix location.
    Regards,
    JD
    Attached Files Attached Files

  4. #4
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,436
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    JD,

    Ok, took a little work but I think I've got it?

    Here's the code:
    Code:
    Option Explicit
    
    Sub CreateYearTable()
    
       Dim lFirstCol As Long
       Dim lFirstRow As Long
       Dim lLastCol  As Long
       Dim lLastRow  As Long
       Dim lYearCol  As Long
       Dim lCntr     As Long
       Dim vCurrCols()   As Variant
       Dim lCurrsCnt As Long
    
       Cells.Find(What:="Year", _
                   After:=Cells(1, 1), _
                   LookIn:=xlValues, _
                   LookAt:=xlWhole, _
                   SearchOrder:=xlByRows, _
                   SearchDirection:=xlNext, _
                   MatchCase:=False, _
                   SearchFormat:=False).Activate
       
    '*** Gather Table Info/demensions ***
    
       With ActiveCell
           lYearCol = .Column
           lFirstRow = .Row
           lLastRow = .End(xlDown).Row
           lLastCol = .End(xlToRight).Column
           lFirstCol = Cells(lFirstRow, lLastCol).End(xlToLeft).Column
       End With 'Activecell
       
    '*** Find Currency formatted columns ***
       lCurrsCnt = 0
       For lCntr = lFirstCol To lLastCol
          If InStr(Cells(lFirstRow + 1, lCntr).NumberFormat, "$") <> 0 Then
            lCurrsCnt = lCurrsCnt + 1
            ReDim Preserve vCurrCols(1 To lCurrsCnt)
            vCurrCols(lCurrsCnt) = lCntr - (lFirstCol - 1)
          End If
       Next lCntr
       
       Debug.Print UBound(vCurrCols)
       
    '*** Create Subtotals ***
       With Range(Cells(lFirstRow, lFirstCol), Cells(lLastRow, lLastCol))
           
           .Subtotal GroupBy:=lYearCol - (lFirstCol - 1), Function:=xlSum, TotalList:=Array(vCurrCols), _
            Replace:=True, PageBreaks:=False, SummaryBelowData:=True
            
       End With  'Range()
       
    '*** Format Table ***
    
       lLastRow = Cells(lFirstRow, lFirstCol).End(xlDown).Row
       Range(Cells(lFirstRow, lFirstCol), Cells(lLastRow, lLastCol)).Select
       ActiveSheet.Cells.FormatConditions.Delete  '*** Clear any Existing Conditional Formatting ***
       
       With Selection
           .FormatConditions.Add Type:=xlExpression, Formula1:= _
             "=ISNUMBER(FIND(""Total""," & _
                Cells(lFirstRow, lFirstCol).Address(False, True, xlA1) & "))"
           .FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
             
           With .FormatConditions(1)
           
               .StopIfTrue = False
    
               With .Font
                   .Color = -16727809
                   .TintAndShade = 0
               End With '.Font
               
               With .Interior
                  .PatternColorIndex = xlAutomatic
                  .ThemeColor = xlThemeColorLight2
                 .TintAndShade = 0
               End With '.Interior
               
           End With  '.Format...(1)
           
      End With  'Range
    
      Cells(lFirstRow, lFirstCol).Select   '*** Clear Selection ***
    
    End Sub  'CreateYearTable
    The code will find the Year title then determine the dimensions of the table from that point in all directions. It will also find the columns that are formatted as Currency (Note: this depends on the $ being in the format!).

    I tested this with your sample and it gives identical results. I also deleted Col A and it still worked. I then added about 10 blank columns in front and it still worked. Lastly I added 10 rows above the table and bingo!

    HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  5. #5
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post
    Hi RG
    Sorry for the delay in replying on this thread. The code is working fine. I am facing few concerns in the code. Actually my data starts from B4 cell instead of A1. I tweaked the code and it works fine, but the formatting of the subtotal won’t work for it. I tried to find fix it, but failed to identify the line of code.
    Also, the range I usually keep for my CF is column name instead of setting it on the rows. Example if I have data from B4 to H21. The current code will apply the CF in range B4:H21 instead can we set it $B:$H. Is it possible?
    Regards,
    JD

  6. #6
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post
    Hi RG
    I got the error and fixed it. The issue was with the column it was finding the word Total. As per my sample file it is Column B and in my real data it is column C.
    Please let me know if this is possible in the current scenario the Year is in column B, but it not mandate to be at Column B it will keeps on changing its location in. I believe the changes needs to be done in the below line of code.
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
    "=ISNUMBER(FIND(""Total""," & _
    Cells(lFirstRow, lFirstCol).Address(False, True, xlA1) & "))"
    Instead of Cells(lFirstRow, lFirstCol) can we find the column heading with the word Year and then the rest of the code should execute
    Regards,
    JD

  7. #7
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post
    Hi RG

    I somehow managed to get it workable. Thanks for all your support and help.
    Regards,
    JD

  8. #8
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,436
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    JD,

    You have me a bit confused but I'm glad you got it working. I'd be interested in seeing your final solution.
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  9. #9
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post

    Post

    Hi RG

    I was bit confused initially with the code. The reason for my confusion is that the header Year changes in most of my report. I tweaked your code little bit and it is working fine now.

    Code:
    Sub CreateYearTable()
    
       Dim lFirstCol As Long
       Dim lFirstRow As Long
       Dim lLastCol  As Long
       Dim lLastRow  As Long
       Dim lYearCol  As Long
       Dim lCntr     As Long
       Dim vCurrCols()   As Variant
       Dim lCurrsCnt As Long
    
       Cells.Find(What:="Policy Year", _
                   After:=Cells(4, 2), _
                   LookIn:=xlValues, _
                   LookAt:=xlWhole, _
                   SearchOrder:=xlByRows, _
                   SearchDirection:=xlNext, _
                   MatchCase:=False, _
                   SearchFormat:=False).Activate
       
    '*** Gather Table Info/demensions ***
    
       With ActiveCell
           lYearCol = .Column
           lFirstRow = .Row
           lLastRow = .End(xlDown).Row
           lLastCol = .End(xlToRight).Column
           lFirstCol = Cells(lFirstRow, lLastCol).End(xlToLeft).Column
       End With 'Activecell
       
    '*** Find Currency formatted columns ***
       lCurrsCnt = 0
       For lCntr = lFirstCol To lLastCol
          If InStr(Cells(lFirstRow + 1, lCntr).NumberFormat, "$") <> 0 Then
            lCurrsCnt = lCurrsCnt + 1
            ReDim Preserve vCurrCols(1 To lCurrsCnt)
            vCurrCols(lCurrsCnt) = lCntr - (lFirstCol - 1)
          End If
       Next lCntr
       
    '   Debug.Print UBound(vCurrCols)
       
    '*** Create Subtotals ***
       With Range(Cells(lFirstRow, lFirstCol), Cells(lLastRow, lLastCol))
           
           .Subtotal GroupBy:=lYearCol - (lFirstCol - 1), Function:=xlSum, TotalList:=Array(vCurrCols), _
            Replace:=True, PageBreaks:=False, SummaryBelowData:=True
            
       End With  'Range()
       
    '*** Format Table ***
    
       Cells.Find(What:="Policy Year", _
                   After:=Cells(4, 2), _
                   LookIn:=xlValues, _
                   LookAt:=xlWhole, _
                   SearchOrder:=xlByRows, _
                   SearchDirection:=xlNext, _
                   MatchCase:=False, _
                   SearchFormat:=False).Activate
                   With ActiveCell
      
                  lLastRow = .End(xlDown).Row
         
                  End With
       Range(Cells(lFirstRow, lFirstCol), Cells(lLastRow, lLastCol)).Select
       ActiveSheet.Cells.FormatConditions.Delete  '*** Clear any Existing Conditional Formatting ***
       
      With Selection
           .FormatConditions.Add Type:=xlExpression, Formula1:= _
             "=ISNUMBER(FIND(""Total""," & _
                Cells(lFirstRow, lYearCol).Address(False, True, xlA1) & "))"
         
           .FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
             
           With .FormatConditions(1)
           
               .StopIfTrue = False
    
               With .Font
                   .Color = -16727809
                   .Bold = True
                  .TintAndShade = 0
               End With '.Font
               
               With .Interior
               .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorLight2
                 .TintAndShade = 0
               End With '.Interior
               
           End With  '.Format...(1)
           
      End With  'Range
    
      Cells(lFirstRow, lFirstCol).Select   '*** Clear Selection ***
    
    End Sub

  10. #10
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,436
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    JD,

    You do realize that by making this change:
    Cells.Find(What:="Policy Year", _
    After:=Cells(4, 2), _

    It will not search Rows 1-3 or Col A!

    The design of the original code was to be totally position independent. This post is just to make sure you understand the implications of the change. HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  11. #11
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post
    Hi RG

    You are correct and I agree with your point. My real data starts from cell B4 and that is the reason I change the cell value to cell(4,2) in the code.

    Regards,
    JD

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •