dpaton05
Well-known Member
- Joined
- Aug 14, 2018
- Messages
- 2,375
- Office Version
- 365
- 2016
- Platform
- Windows
I have alternate colours in my table to help with reading it but I have another procedure that copies rows to it. When that happens, the rows are all pasted in as one colour, even if there are more than 1.
This is what it looks like after 3 entries have been copied to it, notice that the are not copied to still has the alternate colours from column M.
I have a button at the top of the spreadsheet that adds one row at a time and even it does it.
Do I need to add code that formats it all with alternate colours in the rows that runs at the end?
If so, what is that code?
Here is the copy procedure
and
This is what it looks like after 3 entries have been copied to it, notice that the are not copied to still has the alternate colours from column M.
CSS_quoting_tool_31.3.xlsm | ||||||||||||||||||
---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | |||
4 | Date | Purchase order # | Quote Ref # | Name | Service | Requesting Organisation | Caseworker Name | Allocated to | Wait Time/Hrs | Price ex. GST | GST | Price inc. GST | Date report received | Date report sent | Allocated by | Report sent by | ||
5 | 07/07/2020 | 50954 | Bob | Transport | My organisation | Me | $71.10 | $7.11 | $78.21 | |||||||||
6 | 07/07/2020 | 50954 | Bob | Transport | My organisation | Me | $71.10 | $7.11 | $78.21 | |||||||||
7 | 07/07/2020 | 50954 | Bob | Transport | My organisation | Me | $55.80 | $5.58 | $61.38 | |||||||||
Costing_tool |
I have a button at the top of the spreadsheet that adds one row at a time and even it does it.
Do I need to add code that formats it all with alternate colours in the rows that runs at the end?
If so, what is that code?
Here is the copy procedure
VBA Code:
Sub cmdSend()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim desWS As Worksheet, srcWS As Worksheet
Set srcWS = ThisWorkbook.Sheets("CSS_quote_sheet")
Set desWS = ThisWorkbook.Sheets("Costing_tool")
Dim lastRow1 As Long, lastRow2 As Long
Dim i As Long, X As Long, header As Range
lastRow1 = srcWS.Range("B" & srcWS.Rows.Count).End(xlUp).Row
lastRow2 = desWS.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With srcWS.Range("A:A,B:B,D:D,H:H")
If lastRow2 < 5 Then
lastRow2 = 5
For i = 1 To .Areas.Count
X = .Areas(i).Column
Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, Lookat:=xlWhole)
If Not header Is Nothing Then
srcWS.Range(srcWS.Cells(11, X), srcWS.Cells(lastRow1, X)).Copy
desWS.Cells(lastRow2, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
With desWS
If .Range("A" & .Rows.Count).End(xlUp).Row > 5 Then
desWS.ListObjects.Item("tblCosting").ListRows.Add
.ListObjects.Item("tblCosting").DataBodyRange.Columns(1).NumberFormat = "dd/mm/yyyy"
End If
.Range("C" & lastRow2 & ":C" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("H4")
.Range("D" & lastRow2 & ":D" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("B5")
.Range("F" & lastRow2 & ":F" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("B7")
.Range("G" & lastRow2 & ":G" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("B6")
End With
Else
lastRow2 = desWS.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
desWS.ListObjects.Item("tblCosting").ListRows.Add
For i = 1 To .Areas.Count
X = .Areas(i).Column
Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, Lookat:=xlWhole)
If Not header Is Nothing Then
srcWS.Range(srcWS.Cells(11, X), srcWS.Cells(lastRow1, X)).Copy
desWS.Cells(lastRow2 + 1, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
With desWS
.Range("C" & lastRow2 + 1 & ":C" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("H4")
.Range("D" & lastRow2 + 1 & ":D" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B5")
.Range("F" & lastRow2 + 1 & ":F" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B7")
.Range("G" & lastRow2 + 1 & ":G" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B6")
End With
End If
End With
desWS.ListObjects("tblCosting").Sort.SortFields.Clear
desWS.ListObjects("tblCosting").Sort.SortFields. _
Add Key:=desWS.Cells(, 1), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With desWS.ListObjects("tblCosting").Sort
.header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With desWS.ListObjects("tblCosting")
Call AltColours
End With
Call AddName
With Application
.CutCopyMode = False
.EnableEvents = True
.ScreenUpdating = True
End With
Dim oLst As ListObject
Dim lr As Long, Rng As Range
lr = desWS.Cells(Rows.Count, "A").End(xlUp).Row
For i = lr To 4 Step -1
Set Rng = desWS.Cells(i, 1)
If WorksheetFunction.CountBlank(Rng) = 1 Then
desWS.Rows(i).Delete
End If
Next i
End Sub
and
VBA Code:
Sub AltColours()
Dim Rng As Range
Set Rng = Selection
With Rng.FormatConditions.Add(Type:=xlExpression, Formula1:="=MOD(ROW(),2)=0")
.Interior.Color = RGB(208, 216, 232)
.Borders.LineStyle = xlContinuous
.Borders.ThemeColor = 1
.Borders.Weight = xlThin
End With
With Rng.FormatConditions.Add(Type:=xlExpression, Formula1:="=MOD(ROW(),2)=1")
.Interior.Color = RGB(233, 237, 244)
.Borders.LineStyle = xlContinuous
.Borders.ThemeColor = 1
.Borders.Weight = xlThin
End With
End Sub