Sub Summarise() Dim lr As Long Dim ws As Worksheet, ws1 As Worksheet, sh As Worksheet Set ws = Sheet1 Set ws1 = Sheet2 Set sh = Sheet3 Application.ScreenUpdating = False sh.UsedRange.Offset(1).ClearContents lr = ws.Range("A" & Rows.Count).End(xlUp).Row If lr > 1 Then Union(ws.Range("A2:B" & lr), ws.Range("M2:N" & lr)).Copy sh.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlValues End If lr = ws1.Range("A" & Rows.Count).End(xlUp).Row If lr > 1 Then Union(ws1.Range("A2:B" & lr), ws1.Range("P2:Q" & lr)).Copy sh.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlValues End If lr = sh.Range("A" & Rows.Count).End(xlUp).Row sh.[E2] = "=C2" sh.Range("E3:E" & lr) = "=$C3+$E2" For i = 2 To lr If sh.Cells(i, 4).Value = "E" Then sh.Cells(i, 3) = "-" & sh.Cells(i, 3).Value If Left(sh.Cells(i, 5), 1) = "-" Then sh.Cells(i, 5).Font.ColorIndex = 3 Else: sh.Cells(i, 5).Font.ColorIndex = 1 End If End If Next Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
sh.Range("A2", sh.Range("D" & sh.Rows.Count).End(xlUp)).Sort sh.[A2], 1
DON'T MISS