Results 1 to 3 of 3

Thread: change table top row to a different colour with html code

  1. #1
    Member
    Join Date
    May 2013
    Posts
    84
    Rep Power
    12

    change table top row to a different colour with html code

    Hi

    Is there a way to make the top row of the table that is imported into the emails in this code a different colour?

    I have tried to add normal html codes but these come up with a syntax error I can change the whole table colour





    Free Excel\VBA Help Forum (cross post)


    Code:
    Private Sub Workbook_Open()
    
    Dim rngbody As Range
    Dim c As Variant
    Dim ddiff As Long
    Dim mdiff As Long
    Dim body As String
    Dim w As Worksheet
    Dim j As Integer
    Dim cell As Range
    Dim strto As String
        
        
    
    
    
    
    For Each w In Worksheets
        If w.CodeName <> "Sheet2" Then
    
         strto = ""
        For Each cell In w.Range("A3:k200")
            If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0, 6).Value) = "yes" Then
                strto = strto & cell.Value & ";"
            End If
        Next cell
        If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
        
        
        
    Application.EnableEvents = False
            '///New Code
            Set rngbody = w.Range("A2").Resize(1, 7)
            '///
            ' Set the initial email body.  We will use this to check if we have issues later.
            body = "The Following items are Due or Overdue Inspection" & ": " & Chr(9) & Chr(9) & Chr(9) & vbCrLf & vbCrLf & vbCrLf
            For Each c In w.Range("F4:F" & w.Cells(Rows.Count, 6).End(xlUp).Row)
                ' If each value in the range is a date, then do a check for months and days.
                If IsDate(c.Value) Then
                    ddiff = DateDiff("d", Now(), c.Value)
                    mdiff = DateDiff("m", Now(), c.Value)
                    ' If greater than 1 month away, only populate the cell, do not add to the email
                    ' body.  You many want to change this.
                    If ddiff > 0 Then
                        c.Offset(0, 1).Value = ddiff & "  Days From Now"
                    Else
                    ' Else, if we have less than one month, use days as the indicator, and
                    ' increment the email body.
                        If ddiff > 1 Then
                            c.Offset(0, 1).Value = ddiff & " Days From Now"
                            body = body & c.Offset(0, -4) & ": " & Chr(9) & c.Offset(0, -3) & Chr(9) & Chr(9) & Chr(9) & ddiff & " Days from now" & vbCrLf
                    Else
                        If ddiff = 0 Then
                            c.Offset(0, 1).Value = "Due Today"
                            body = body & c.Offset(0, -4) & ": " & Chr(9) & c.Offset(0, -5) & ": " & Chr(9) & Chr(9) & c.Offset(0, -3) & ": " & Chr(9) & c.Offset(0, -1) & ": " & Chr(9) & " Due today" & ": " & vbCrLf
                    Else
                        c.Offset(0, 1).Value = ddiff * -1 & " Days Overdue"
                        body = body & c.Offset(0, -4) & ": " & Chr(9) & c.Offset(0, -5) & ": " & Chr(9) & c.Offset(0, -3) & ": " & Chr(9) & c.Offset(0, -1) & ": " & Chr(9) & ddiff * -1 & " Days overdue" & ": " & vbCrLf
                        '///New Code
                        Set rngbody = Union(rngbody, c.Offset(0, -5).Resize(1, 7))
                        '///
                    End If
                    End If
                    End If
                End If
            Next c
            '///New Code
            If rngbody.Rows.Count > 1 Or rngbody.Areas.Count > 1 Then
            rngbody.Copy Sheet2.Range("A1")
            '///
            sn = Sheet2.Range("A1").CurrentRegion
            c01 = "<table border=1 bgcolor=#F3E2A9 >"
            
    
        
        
    
            
    
            
            On Error Resume Next
    For j = 1 To UBound(sn)
             c01 = c01 & "<tr><td>" & Join(Application.Index(sn, j), "</td><td>") & "</td></tr>"
    Next
    c01 = c01 & "</table><P></P><P></P>"
    
    On Error GoTo 0 '//Resets the error handler to break code in the event of an error
    
            
    
    
            
            
           
         
            With CreateObject("Outlook.Application").CreateItem(0)
                .To = strto
                .cc = ""
                .bcc = "northsidevan@gmail.com"
                .Subject = "Northside Bradford's Overdue " & w.Name & " Safety Checks "
                .HTMLBody = "The Items In The Table Below Are Overdue Please Complete and Update Spread Sheet A.S.A.P" & c01
                .display
                
                
          
            End With
            
            Sheet2.Cells(1).CurrentRegion.Offset(1).ClearContents
        End If
        End If
        
     Next w
    Application.EnableEvents = True
                
    End Sub

    Regards

    Peter
    Attached Files Attached Files
    Last edited by peter renton; 02-13-2014 at 07:19 PM. Reason: added code

  2. #2
    Member p45cal's Avatar
    Join Date
    Oct 2013
    Posts
    94
    Rep Power
    12
    try:
    Code:
    Private Sub Workbook_Open()
    Dim rngbody As Range
    Dim c As Variant
    Dim ddiff As Long
    Dim mdiff As Long
    Dim body As String
    Dim w As Worksheet
    Dim j As Integer
    Dim cell As Range
    Dim strto As String
    Dim frRowCol as String
    
    For Each w In Worksheets
     If w.CodeName <> "Sheet2" Then
        strto = ""
        For Each cell In w.Range("A3:k200")
          If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0, 6).Value) = "yes" Then
            strto = strto & cell.Value & ";"
          End If
        Next cell
        If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
        Application.EnableEvents = False
    '///New Code
        Set rngbody = w.Range("A2").Resize(1, 7)
    '///
    ' Set the initial email body.  We will use this to check if we have issues later.
        body = "The Following items are Due or Overdue Inspection" & ": " & Chr(9) & Chr(9) & Chr(9) & vbCrLf & vbCrLf & vbCrLf
        For Each c In w.Range("F4:F" & w.Cells(Rows.Count, 6).End(xlUp).Row)
    ' If each value in the range is a date, then do a check for months and days.
          If IsDate(c.Value) Then
            ddiff = DateDiff("d", Now(), c.Value)
            mdiff = DateDiff("m", Now(), c.Value)
    ' If greater than 1 month away, only populate the cell, do not add to the email
    ' body.  You many want to change this.
            If ddiff > 0 Then
              c.Offset(0, 1).Value = ddiff & "  Days from now"
            Else
    ' Else, if we have less than one month, use days as the indicator, and
    ' increment the email body.
              If ddiff > 1 Then
                c.Offset(0, 1).Value = ddiff & " days from now"
                body = body & c.Offset(0, -4) & ": " & Chr(9) & c.Offset(0, -3) & Chr(9) & Chr(9) & Chr(9) & ddiff & " Days from now" & vbCrLf
              Else
                If ddiff = 0 Then
                  c.Offset(0, 1).Value = "due today"
                  body = body & c.Offset(0, -4) & ": " & Chr(9) & c.Offset(0, -5) & ": " & Chr(9) & Chr(9) & c.Offset(0, -3) & ": " & Chr(9) & c.Offset(0, -1) & ": " & Chr(9) & " Due today" & ": " & vbCrLf
                Else
                  c.Offset(0, 1).Value = ddiff * -1 & " days overdue"
                  body = body & c.Offset(0, -4) & ": " & Chr(9) & c.Offset(0, -5) & ": " & Chr(9) & c.Offset(0, -3) & ": " & Chr(9) & c.Offset(0, -1) & ": " & Chr(9) & ddiff * -1 & " Days overdue" & ": " & vbCrLf
    '///New Code
                  Set rngbody = Union(rngbody, c.Offset(0, -5).Resize(1, 7))
    '///
                End If
              End If
            End If
          End If
        Next c
    '///New Code
        rngbody.Copy Sheet2.Range("A1")
    '///
        sn = Sheet2.Range("A1").CurrentRegion
        c01 = "<table border=1 >"  'pd: we need to find out how to colour the background of the first row only rather than the whole table.
        On Error Resume Next
        For j = 1 To UBound(sn)
          If j = 1 Then frRowCol = " bgcolor=#A9BCF5 " Else frRowCol = ""
          c01 = c01 & "<tr" & frRowCol & " ><td>" & Join(Application.Index(sn, j), "</td><td>") & "</td></tr>"
        Next j
        c01 = c01 & "</table><P></P><P></P>"
        On Error GoTo 0  '//Resets the error handler to break code in the event of an error
        With CreateObject("Outlook.Application").CreateItem(0)
          .To = strto
          .cc = ""
          .bcc = "northsidevan@gmail.com"
          .Subject = "Northside Leeds " & w.Name & " Safety Checks "
          .HTMLBody = "The Items In The Table Below Are Overdue Please Complete and Update Spread Sheet" & c01
          .display
        End With
        Sheet2.Cells(1).CurrentRegion.Offset(1).ClearContents
      End If
    Next w
    Application.EnableEvents = True
    End Sub
    If you wanted to control both first and subsequent row colours then change:
    Code:
    If j = 1 Then frRowCol = " bgcolor=#A9BCF5 " Else frRowCol = ""
    to for example:
    Code:
    If j = 1 Then frRowCol = " bgcolor=#A9BCF5 " Else frRowCol = " bgcolor=#FC9F9F"
    or if you wanted to alternate the 2nd and subsequent row colours, something like:
    Code:
    If j = 1 Then frRowCol = " bgcolor=#A9BCF5 " Else If Application.IsOdd(j) Then frRowCol = " bgcolor=#FC9F9F" Else frRowCol = " bgcolor=#FCD2D2"
    Last edited by p45cal; 02-15-2014 at 10:29 PM.

  3. #3
    Member
    Join Date
    May 2013
    Posts
    84
    Rep Power
    12
    Thank You p45cal

    That's just what I was looking for, makes it look a lot better,


    Cheers Peter

Similar Threads

  1. A code to show colour in cell from list
    By rodneykaye in forum Excel Help
    Replies: 4
    Last Post: 10-18-2013, 03:56 PM
  2. Replies: 30
    Last Post: 07-19-2013, 07:52 AM
  3. Change Pivot Table Data Source Using A Drop Down List
    By hanishgautam in forum Excel and VBA Tips and Tricks
    Replies: 0
    Last Post: 07-05-2013, 09:33 AM
  4. Delte a specific column and does not delete the top row
    By jffryjsphbyn in forum Excel Help
    Replies: 1
    Last Post: 06-13-2013, 02:00 PM
  5. Replies: 3
    Last Post: 03-05-2013, 03:57 PM

Posting Permissions

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