dpaton05
Well-known Member
- Joined
- Aug 14, 2018
- Messages
- 2,352
- Office Version
- 365
- 2016
- Platform
- Windows
I have a table with many lines and it has an alternating colour background on each line to make it easier to read it. For instance, the first row is light blue, the second row is bit darker and it alternates the colours. I have a second table that the first table's values are copied to. It is meant to have alternating colours too but when I copy the rows from the first to the second table, I don't get the alternating colours in the second table. If 10 rows are copied, the 10 rows are inserted into the second table, but all with the same background colour, ie, without the alternating colour background. Could someone look at my code and tell me why this has happened please?
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
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