Need row colour to be purple if a value is in a cell for each row

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,362
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I have a spreadsheet that copies rows from a table to separate documents depending on several factors. This is the code from my copy button.
Code:
Sub cmdCopy()
        Dim wsDst As Worksheet, wsSrc As Worksheet, tblrow As ListRow
        Dim Combo As String, sht As Worksheet, tbl As ListObject
        Dim LastRow As Long, DocYearName As String, lr As Long
        Dim w As Window
            Application.ScreenUpdating = False
        'assign values to variables
        Set tbl = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting")
        Set sht = ThisWorkbook.Worksheets("Costing_tool")
        For Each tblrow In tbl.ListRows
            If tblrow.Range.Cells(1, 1).Value = "" Or tblrow.Range.Cells(1, 5).Value = "" Or tblrow.Range.Cells(1, 6).Value = "" Then
                MsgBox "The Date, Service or Requesting Organisation has not been entered for every record in the table"
                Exit Sub
            End If
        Next tblrow
        For Each tblrow In tbl.ListRows
            Combo = tblrow.Range.Cells(1, 26).Value
            
                Select Case tblrow.Range.Cells(1, 6).Value
                    Case "Ang Wes", "Ang Riv", "Yir"
                        DocYearName = tblrow.Range.Cells(1, 37).Value
                    Case Else
                        DocYearName = tblrow.Range.Cells(1, 36).Value
                End Select

            
            
            If Not isFileOpen(DocYearName & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "" & DocYearName & ".xlsm"

            Set wsDst = Workbooks(DocYearName).Worksheets(Combo)
             lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
             With wsDst
                    'This copies the first 16 columns, i.e. A:J, of the current row of the table to column A in the destination sheet.
                    tblrow.Range.Resize(, 16).Copy
                    'This pastes in the figures in the first 10 columns starting in column A
                    .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
                    'Overwrites the numbers pasted to column I with a formula
                    .Range("I" & .Range("I" & .Rows.Count).End(xlUp).Row).Formula = "=IF(R[0]C[-4]=""Activities"",0,RC[-1]*0.1)"
                    'Overwrites the numbers pasted to column J with a formula
                    .Range("J" & .Range("J" & .Rows.Count).End(xlUp).Row).Formula = "=IF(R[1]C[-5]=""Activities"",RC[-2],RC[-1]+RC[-2])"
                    'sort procedure copied from vba
                    wsDst.Sort.SortFields.Clear
                    wsDst.Sort.SortFields.Add Key:=Range("A4:A" & lr), _
                        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                            With Workbooks(DocYearName).Worksheets(Combo).Sort
                                .SetRange Range("A3:AK" & lr)
                                .header = xlYes
                                .MatchCase = False
                                .Orientation = xlTopToBottom
                                .SortMethod = xlPinYin
                                .Apply
                            End With

                End With
        Next tblrow
        sht.Protect
        
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
End Sub

If cell 6 has Yir in it, the row will be copied to the document name stored in cell 37. I need the new whole row (in the filename stored in cell 37) to be -65383 colour. Can someone help me with the code please?

Thanks,
Dave
 
Do you want to upload the latest version anyway ??
 
Upvote 0

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

Forum statistics

Threads
1,223,236
Messages
6,170,917
Members
452,366
Latest member
TePunaBloke

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