dpaton05
Well-known Member
- Joined
- Aug 14, 2018
- Messages
- 2,375
- Office Version
- 365
- 2016
- Platform
- 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.
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
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 SubIf 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
