Cells Format and subtotals with VBA - vba

I have created a VBA macro to give the format to Sheet in excel and create some subtotals.
It works, but has a lot of room for improvement.
Right now it takes very long.
I know that using Matrix the processing time could be reduced to milliseconds.
Sub justsubttotals()
Sheets("Produktionsplan").Select
'Delete previous format
Range("A4:I1000").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
'I define 3 start variables with the first row of the matrix (per default it always starts in row 4).
primero = 4
fin = 4
contar = 4
'Identify how many rows are in the file
Finalrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For j = 4 To Finalrow
If Cells(j, 1) = 0 And contar <= Finalrow Then
Cells(j, 1).Select
Selection.EntireRow.Select
Selection.Delete Shift:=xlUp
j = j - 1
contar = contar + 1
Else
contar = contar + 1
End If
Next
inicio = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Este inicio lo guardo para la parte de los subtotales
inicio2 = inicio
'Este inicio si es para los formatos
inicio = inicio + 1
For i = 4 To inicio
For j = primero To inicio
If Cells(primero, 4) = Cells(fin + 1, 4) Then
fin = fin + 1
Else
j = inicio
End If
Next
'Based on the description of column 2, I know which colour to assign
If Cells(primero, 2) = "B. Rück RH" Or Cells(primero, 2) = "B. 7 OB RH" Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.699981688894314
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "B. Rück LH" Or Cells(primero, 2) = "B. 7 OB LH" Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.499981688894314
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "B. 7 SAMS Center " Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 8771461
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "B. 7 SAMS LH " Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 8771461
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "B. 7 SAMS RH " Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 8771461
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "B. 634 RH/LH " Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 6723891
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "B. Vor RH" Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.699981688894314
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "B. Vor LH" Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.699981688894314
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "Porsche RH" Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "Porsche LH" Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.399993896298105
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "Audi RH" Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.ThemeColor = xlThemeColorDark2
.TintAndShade = -9.99786370433668E-02
.TintAndShade = 0.699981688894314
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "Audi LH" Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Else
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Range("A" & primero & ":I" & fin).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
primero = fin + 1
Next
'************************************************
'I create the subtotals
'************************************************
primero = 4
fin = 4
inicio = inicio2
For i = 4 To inicio
For j = primero To inicio
If Cells(primero, 4) = Cells(fin + 1, 4) Then
fin = fin + 1
Else
j = inicio
End If
Next
If fin > primero Then
Rows(fin + 1 & ":" & fin + 1).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
inicio = inicio + 1
Range("H" & fin + 1).Select
Cells(fin + 1, 8).Value = "=Sum(H" & primero & ":H" & fin & ")"
Range("H" & fin + 1).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Font.Bold = True
Else
Range("H" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Font.Bold = True
End If
primero = fin + 1
Next
'************************************************
'I use the formula of another sheet
'************************************************
Sheets("RuestenMatrix").Select
Range("J1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Produktionsplan").Select
Range("J4:J810").Select
ActiveSheet.Paste
'************************************************
'Once again I use the formula of another sheet
'************************************************
Sheets("Pause Zeit").Select
Range("K4:K5").Select
Selection.Copy
Sheets("Produktionsplan").Select
Range("K4").Select
ActiveSheet.Paste
Range("K5").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("K5:K810")
Range("K5:K810").Select
'************************************************
'One more time I use the formula of another sheet
'************************************************
Cells(4, 13).Select
Sheets("Pause Zeit").Select
Range("M4:P5").Select
Selection.Copy
Sheets("Produktionsplan").Select
ActiveSheet.Paste
Range("M5:P5").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("M5:P872")
Range("M5:P872").Select
Range("M4").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Font.Bold = True
End Sub

Related

Compare Two Excel sheets and find the difference

I want to find out or highlight the differences between two Excel sheets.
from above image I want to compare both sheets based on "Name" and "RuleName", if the number matches it needs to check differences for "Text" and "Rule Text" and it needs to find the differences like highlighted text in second Excel document.

This should do:
Sub HighlightDiffBtwSheets()
'Substitute "TEST1" with the name of the sheet where you have the Name-Text columns
'Substitute "TEST2" with the name of the sheet where you have the RuleName-RuleText columns
'Substitute A in the Range with the column letter of Name/RuleName
For Each Name In Sheets("TEST1").Range("A2:A" & Sheets("TEST1").Cells(Rows.Count, 1).End(xlUp).Row)
For Each RuleName In Sheets("TEST2").Range("A2:A" & Sheets("TEST2").Cells(Rows.Count, 1).End(xlUp).Row)
If InStr(RuleName.Value, Name.Value) <> 0 Then
If Name.Offset(, 1).Value <> RuleName.Offset(, 1).Value Then
RuleName.Offset(, 1).Select
With Selection.Interior
.Color = 65535
End With
End If
End If
Next
Next
End Sub

An easier non VBA way to do this is to use Conditional Formatting. Just Create A New Rule, then select Use Formula option. Use a relative reference (no dollar signs) and copy to where you need it. For example, =A1<>Sheet1!A1

I have created this file to compare two excel workbooks few years back, code is very elemantary but it does work with few limitations.
Limitations:
both file should not have same name
it only compare values in the cell, does not compare any graphics.
It is only comparing first 300 rows and first 200 columns, you can very easily update this in code to fit your need.
Code is divided into two subs. 1. Compareworkbook and 2. CreateNewWorksheet
You can creat browse button macro to populate two excel file names in named cell "file1" and named cell "file2". Then you can use Compareworkbook macro to compare two excel files. Once you run "Compareworkbook" macro, it will create new worksheet to show you the report. it only shows the values which are different.
You can modify this code to compare certain columns or to fit your need. This should give you a good starting point.
Sub CompareWorkbook1()
'this subroutine is created to compare two excel files
'This will only compare first 300 rows and 150 column for all worksheet
'in both workbook assuming both workbook has same number of worksheets
Dim wb As Workbook, wb1 As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim wBook1 As Variant
Dim wBook2 As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
wBook1 = ActiveWorkbook.Sheets("Sheet1").Range("file1").Value
wBook2 = ActiveWorkbook.Sheets("Sheet1").Range("file2").Value
Answer = MsgBox("This will generate a new report, Do you want to proceed?", vbQuestion + vbYesNo, "Are you sure? This will delete existing reports and generate new reports")
If Answer = vbNo Then
GoTo exit1
Else
If Range("file1").Value = "" Then
Msg = "ERROR: INFORMATION MISSING ..." & vbNewLine & vbNewLine
Msg = Msg & "Make sure you browse the file "
Msg = Msg & "by clicking on Browse button next to Step 1 " & vbNewLine & vbNewLine
Msg = Msg & "REPORT WILL NOT GENERATE"
MsgBox Msg, vbCritical
GoTo exit1
End If
If Range("file2").Value = "" Then
Msg = "ERROR: INFORMATION MISSING ..." & vbNewLine & vbNewLine
Msg = Msg & "Make sure you browse the file "
Msg = Msg & "by clicking on Browse button next to Step 2 " & vbNewLine & vbNewLine
Msg = Msg & "REPORT WILL NOT GENERATE"
MsgBox Msg, vbCritical
GoTo exit1
End If
'generate new worksheet
ReportName = "Comparison Results"
Call CreateNewWorksheet(ReportName)
'set workbooks as variable wb1 and wb2
Set wb1 = Workbooks.Open(wBook1)
Set wb2 = Workbooks.Open(wBook2)
wb.Sheets(2).Cells(4, 2).Value = wb1.Name
wb.Sheets(2).Cells(4, 3).Value = wb2.Name
wb.Sheets(2).Cells(3, 7).Value = wb1.Name
wb.Sheets(2).Cells(3, 10).Value = wb2.Name
'Pull data from browsed workbook for All incident
'MsgBox "WOrkbooks are opened"
ThisWorkbook.Activate
Dim oSheet As Excel.Worksheet
'This will populate all Worksheet name in Combo box
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim d As Integer
Dim wSheetsNo As Integer
Dim wSheetsNo1 As Integer
Dim wSheetsNo2 As Integer
a = 1
b = 1
c = 1
d = 1
wSheetsNo1 = 0
wSheetsNo2 = 0
a = 5
b = 2
For Each oSheet In wb1.Sheets
wb.Sheets(2).Cells(a, b) = oSheet.Name
a = a + 1
wSheetsNo1 = wSheetsNo1 + 1
Next oSheet
a = 5
b = 3
For Each oSheet In wb1.Sheets
wb.Sheets(2).Cells(a, b) = oSheet.Name
a = a + 1
wSheetsNo2 = wSheetsNo2 + 1
Next oSheet
a = 5
b = 7
'populates all worksheet from 1st workbook to compare
For wSheetsNo = 1 To wSheetsNo1
'Compares from row 1 to 300
For c = 1 To 300
'Compares columns 1 to 200
For d = 1 To 200
'Compares each cell value in each worksheets for these two workbook
If wb1.Sheets(wSheetsNo).Cells(c, d).Value <> wb2.Sheets(wSheetsNo).Cells(c, d).Value Then
wb.Sheets(2).Cells(a, b + 1) = "Cells (" & c & ", " & d & ")"
wb.Sheets(2).Cells(a, b + 4) = "Cells (" & c & ", " & d & ")"
wb.Sheets(2).Cells(a, b + 2) = wb1.Sheets(wSheetsNo).Cells(c, d).Value
wb.Sheets(2).Cells(a, b + 5) = wb2.Sheets(wSheetsNo).Cells(c, d).Value
wb.Sheets(2).Cells(a, b) = wb1.Sheets(wSheetsNo).Name
wb.Sheets(2).Cells(a, b + 3) = wb2.Sheets(wSheetsNo).Name
a = a + 1
End If
'looks into next column
Next
'looks into next row
Next
'looks into next worksheet
Next
'closes both workbook
wb1.Close
wb2.Close
End If
'exit if files is now browsed or path is empty
exit1:
End Sub
Sub CreateNewWorksheet(ReportName)
Dim wsSheet As Worksheet
On Error Resume Next
Set wsSheet = Sheets(ReportName)
On Error GoTo 0
If Not wsSheet Is Nothing Then
Application.DisplayAlerts = False
Sheets(ReportName).Delete
Application.DisplayAlerts = True
End If
'Add New sheet at end of worksheet
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = ReportName
Sheets("Comparison Results").Select
Range("B4").Select
Sheets("Comparison Results").Select
Range("B3").Select
ActiveCell.FormulaR1C1 = "Worksheets which are compared"
Range("B4").Select
Columns("B:B").ColumnWidth = 27.57
Columns("B:B").Select
Selection.ColumnWidth = 28
Columns("C:C").Select
Selection.ColumnWidth = 28
Range("B3:C3").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.Font.Bold = True
Range("B4").Select
ActiveCell.FormulaR1C1 = "1st Workbook"
Range("C4").Select
ActiveCell.FormulaR1C1 = "2nd Workbook"
Range("B4:C4").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("B3:C50").Select
ActiveWindow.SmallScroll Down:=-45
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("B3:C4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 10092543
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("B5:C50").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 10092543
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("C13").Select
ActiveWindow.SmallScroll Down:=-15
Range("B3:C3").Select
ActiveCell.FormulaR1C1 = "Worksheets which are compared"
Columns("G:L").Select
Selection.ColumnWidth = 28
Selection.ColumnWidth = 10
Selection.ColumnWidth = 15
Selection.ColumnWidth = 18
Range("G3:I3").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.Copy
Range("J3").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("G3:I3").Select
ActiveCell.FormulaR1C1 = ""
Range("G4").Select
ActiveCell.FormulaR1C1 = "Worksheet"
Range("H4").Select
ActiveCell.FormulaR1C1 = "Cell number"
Range("I4").Select
ActiveCell.FormulaR1C1 = "Value in the cell"
Range("G4:I4").Select
Selection.Copy
Range("J4").Select
ActiveSheet.Paste
Range("B4").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("C4").Select
Selection.ClearContents
Range("G3:L10000").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 10092543
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("G3:L4").Select
Selection.Font.Bold = True
Range("B3:C4").Select
Selection.Font.Bold = False
Selection.Font.Bold = True
Range("B4:L4").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("G3:L3").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Range("G5").Select
ActiveWindow.SmallScroll Down:=-15
Range("G3:I3").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range("G3:L3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("G3:L4").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("G3:L10000").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("B3:C4").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("B3:C50").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("G3:I10000").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Columns("D:F").Select
Range("F1").Activate
Selection.ColumnWidth = 3
Range("G2:L2").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 10092543
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("G2:L2").Select
ActiveCell.FormulaR1C1 = "Comparison Results"
Range("G2:L2").Select
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection.Font
.Name = "Calibri"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Range("G2:L2").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'Sheets("Sheet1").Select
Range("B2").Select
Range("G3:L4").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("B1").Select
End Sub

VBA Error 1004 Object Range failed for _Global

I need to make a little VBA Application for a School project.
I recorded a Macro which Resize all Cells and then make them green. After that I select specific Cells and recolor them in white. So the result should be the Excel logo. However when I run the code there is an Error 1004 Range Object failed for _Global.
Code:
Sub Resize()
Columns("A:BZ").ColumnWidth = 2.71
Rows("1:1000").RowHeight = 15
Cells.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 4485149
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Union(Range( _
"O14:P15,L7:T7,S5:T6,P6:Q6,E38:F47,G46:J47,G42:J43,G38:J39,N38:O39,O40:R41,R38:S39,P42:Q43,O44:R45,N46:O47,R46:S47,W38:X47,Y46:AB47,Y38:AB39,AF38:AK39,AF40:AG47,AH46:AK47,AH42:AK43,AO38:AP47,AQ46:AT47,R6,Y7:AP9,AN10:AP31,Y29:AM31,AF10:AF28,AG24:AM24,Y24:AE24" _
), Range( _
"AG19:AM19,AG14:AM14,Y14:AE14,V4:X33,U5:U32,T12:T25,S14:S23,R16:R21,Q18:Q19,Q28:T32,M26:R27,N24:Q25,O22:P23,L28:P31,H28:K30,F9:G29,H8:J27,K12:K25,L14:L23,M16:M21,N18:N19,K8:T9,M10:R11,N12:Q13" _
)).Select
Cells.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub

the string fed to Range must be less then 256 characters, while your first range has just 257... so just shift some characters to the 2nd range
furthermore you're selecting all cells instead of wanted ones
see code:
Option Explicit
Sub Resize()
With Range("A1:BZ1000")
.ColumnWidth = 2.71
.RowHeight = 15
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 4485149
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End With
With Union(Range( _
"O14:P15,L7:T7,S5:T6,P6:Q6,E38:F47,G46:J47,G42:J43,G38:J39,N38:O39,O40:R41,R38:S39,P42:Q43,O44:R45,N46:O47,R46:S47,W38:X47,Y46:AB47,Y38:AB39,AF38:AK39,AF40:AG47,AH46:AK47,AH42:AK43,AO38:AP47,AQ46:AT47,R6,Y7:AP9,AN10:AP31,Y29:AM31" _
), Range( _
"AF10:AF28,AG24:AM24,Y24:AE24,AG19:AM19,AG14:AM14,Y14:AE14,V4:X33,U5:U32,T12:T25,S14:S23,R16:R21,Q18:Q19,Q28:T32,M26:R27,N24:Q25,O22:P23,L28:P31,H28:K30,F9:G29,H8:J27,K12:K25,L14:L23,M16:M21,N18:N19,K8:T9,M10:R11,N12:Q13" _
)).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub

Highlight only a few columns and cells within a row

How could I edit my code to only highlight the row from column G:K instead of wasting memory and time highlighting the entire row?
With ActiveSheet 'set this worksheet properly!
'lastrow = .cells(Rows.Count, 1).End(xlUp).Row
lastrow = Range("K6500").End(xlUp).Row - 2
For Each cell In .Range("K3:K" & lastrow)
If cell = "Wrong Date" Then
'With cell.EntireRow.Interior
With cell.Range("G:K").Value.Interior.ColorIndex = 3
Rows().Select
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 3937500
.TintAndShade = 0
.PatternTintAndShade = 0
End With
My current code does not work as I've tried replacing With cell.EntireRow.Interior with With cell.Range("G:K").Value.Interior.ColorIndex = 3
Excuse me this is what I mean I am trying to do
Sub highlight_wrong_Date()
Dim Rng As Range, lCount As Long, lastrow As Long
Dim cell As Object
With ActiveSheet 'set this worksheet properly!
lastrow = Range("K6500").End(xlUp).Row - 2
For Each cell In .Range("K3:K" & lastrow)
If cell = "Wrong Date" Then
With cell.Range(.cells(cell.Row, "G"), .cells(cell.Row, "K"))
Rows().Select
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 3937500
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ElseIf cell = "Pass" Then
With cell.Range(.cells(cell.Row, "G"), .cells(cell.Row, "K"))
Rows().Select
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 61046
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
With cell.EntireRow.Interior
Rows().Select
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next cell
End With
End Sub
But I receive an error saying the cell object does not support this. If a cell has either a value of "Wrong Date" or "Pass" within column O I want to highlight red or green respectively.
3rd Edit
Sub highlight_wrong_Date()
Dim Rng As Range, lCount As Long, lastrow As Long
Dim cell_value As Object
With ActiveSheet 'set this worksheet properly!
lastrow = Range("K6500").End(xlUp).Row - 2
For Each cell_value In .Range("K3:K" & lastrow)
If cell_value = "Wrong Date" Then
With .Range(.cells(cell.Row, "G"), .cells(cell.Row, "K"))
'Rows().Select
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 3937500
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ElseIf cell_value = "Pass" Then
With .Range(.cells(cell.Row, "G"), .cells(cell.Row, "K"))
'Rows().Select
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 61046
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
With cell.EntireRow.Interior
Rows().Select
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next cell_value
End With
End Sub

Your references should be
With .Range("G" & cell.Row & ":K" & cell.Row)

Skipping cells that are coloured

I have a loop, where I want to skip cells that are coloured.
For i = 1 To Count
Do While ActiveCell.Offset(0, i).Interior.ColorIndex = 15
i = i + 1: Count = Count + 1
Loop
With ActiveCell.Offset(0, i).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
Next i
It works, however the initial count variable is not updated. Thus, if I have 10 and there are 2 skips, the i value is increased and that works, still the count remains at 10, even though the variable says 12. It appears as though increasing the count variable does not increment the For loop. I cannot take 1 away from the i variable because that leads to the activecell.offset being impacted.

Why use .Offset at all? Is this what you are trying? This way you can skip the colored cells as well.
Dim col As Long, rw As Long, i As Long
col = ActiveCell.Column
rw = ActiveCell.Row
For i = 1 To Count
With Cells(rw, col + i)
If .Interior.ColorIndex <> 15 Then
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
End If
End With
Next i

Probably very inefficient code, but there are not a lot of rows. Remember the idea is that the column has a date, if that column is Saturday or Sunday, i.e., coloured grey, then the code should skip those cells and but not subtract them from the overall counter.
If Not IsEmpty(y.Value) And IsNumeric(y.Value) And y.Value >= 7.5 Then
With ActiveCell.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
Col = y.Value - 7.5
Col = Col / 7.5
Count = Left(Col, Len(Col) - InStr(1, Col, ".") + 1)
y = 0
For i = 1 To Count
Do While ActiveCell.Offset(0, i).Interior.ColorIndex = 15
ActiveCell.Offset(0, 1).Select
y = y + 1
Loop
With ActiveCell.Offset(0, i).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
Next i
ActiveCell.Offset(0, -y).Select
ActiveCell.Offset(0, i + y).Select
Do While ActiveCell.Interior.ColorIndex = 15
ActiveCell.Offset(0, 1).Select
Loop
Co = Right(Col, Len(Col) - InStr(1, Col, "."))
If Len(Co) > 2 Then
Co = Mid(Co, 1, InStr(1, Col, ".")) & "." & Mid(Co, InStr(1, Col, ".") + 1, Len(Co) - InStr(1, Col, "."))
End If
If Co = 0 Then
ElseIf Co >= 0.1 And Co <= 25 Then
With ActiveCell.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -4.99893185216834E-02
.PatternTintAndShade = 0
End With
ElseIf Co >= 26 And Co <= 49 Then
With ActiveCell.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
ElseIf Co >= 5 And Co <= 74 Then
With ActiveCell.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
ElseIf Co >= 75 And Co <= 99 Then
With ActiveCell.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -4.99893185216834E-02
.PatternTintAndShade = 0
End With
End If
End If
Next y

Run VBA Script When Cell Value Change by Formula

I need to run a VBA script everytime the value of cell "H18" changes, but contains a formula, and no data is changed "Manually" only by VBA scripts, is there a way to set it up? I've tried a bunch of VBA scripts but no success at all, it works if I change it manually, but not when the formula works. This is the VBA script it should run:
Sub Colorir()
Application.ScreenUpdating = False
Dim iRow, contagem
contagem = 0
iRow = 18
iColumn = 2
' ifim = Sheets("Plan1").Range("C8").Value - 1
Sheets("Calendario").Select
Do While iRow < 30
If Cells(iRow, 2) = "Não Recebido" Then
Cells(iRow, 2).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 8420607
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -8356609
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 2) = "Abaixo do Previsto" Then
Cells(iRow, 2).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 10092390
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -16711681
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 2) = "Igual ou Acima do Previsto" Then
Cells(iRow, 2).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 10092390
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -6684826
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 3) = "Não Recebido" Then
Cells(iRow, 3).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 8420607
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -8356609
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 3) = "Abaixo do Previsto" Then
Cells(iRow, 3).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 10092390
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -16711681
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 3) = "Igual ou Acima do Previsto" Then
Cells(iRow, 3).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 10092390
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -6684826
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 4) = "Não Recebido" Then
Cells(iRow, 4).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 8420607
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -8356609
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 4) = "Abaixo do Previsto" Then
Cells(iRow, 4).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -16711681
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 4) = "Igual ou Acima do Previsto" Then
Cells(iRow, 4).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 10092390
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -6684826
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 5) = "Não Recebido" Then
Cells(iRow, 5).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 8420607
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -8356609
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 5) = "Abaixo do Previsto" Then
Cells(iRow, 5).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 10092390
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -16711681
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 5) = "Igual ou Acima do Previsto" Then
Cells(iRow, 5).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 10092390
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -6684826
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 6) = "Não Recebido" Then
Cells(iRow, 6).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 8420607
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -8356609
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 6) = "Abaixo do Previsto" Then
Cells(iRow, 6).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 10092390
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -16711681
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 6) = "Igual ou Acima do Previsto" Then
Cells(iRow, 6).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 10092390
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -6684826
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 7) = "Não Recebido" Then
Cells(iRow, 7).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 8420607
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -8356609
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 7) = "Abaixo do Previsto" Then
Cells(iRow, 7).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 10092390
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -16711681
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 7) = "Igual ou Acima do Previsto" Then
Cells(iRow, 7).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 10092390
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -6684826
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 8) = "Não Recebido" Then
Cells(iRow, 8).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 8420607
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -8356609
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 8) = "Abaixo do Previsto" Then
Cells(iRow, 8).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 10092390
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -16711681
.TintAndShade = 0
End With
Else
End If
If Cells(iRow, 8) = "Igual ou Acima do Previsto" Then
Cells(iRow, 8).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 10092390
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.color = -6684826
.TintAndShade = 0
End With
Else
End If
If Range("S18").Value < Range("T18").Value Then
Range("B18, C18, D18, E18, F18, G18, H18").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 10092390
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("S18").Value > Range("T18").Value Then
Range("B18, C18, D18, E18, F18, G18, H18").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("T18").Value = 0 Then
Range("B18, C18, D18, E18, F18, G18, H18").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 8420607
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("S20").Value < Range("T20").Value Then
Range("B20, C20, D20, E20, F20, G20, H20").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 10092390
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("S20").Value > Range("T20").Value Then
Range("B20, C20, D20, E20, F20, G20, H20").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("T20").Value = 0 Then
Range("B20, C20, D20, E20, F20, G20, H20").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 8420607
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("S22").Value < Range("T22").Value Then
Range("B22, C22, D22, E22, F22, G22, H22").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 10092390
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("S22").Value > Range("T22").Value Then
Range("B22, C22, D22, E22, F22, G22, H22").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("T22").Value = 0 Then
Range("B22, C22, D22, E22, F22, G22, H22").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 8420607
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("S24").Value < Range("T24").Value Then
Range("B24, C24, D24, E24, F24, G24, H24").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 10092390
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("S24").Value > Range("T24").Value Then
Range("B24, C24, D24, E24, F24, G24, H24").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("T24").Value = 0 Then
Range("B24, C24, D24, E24, F24, G24, H24").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 8420607
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("S26").Value < Range("T26").Value Then
Range("B26, C26, D26, E26, F26, G26, H26").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 10092390
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("S26").Value > Range("T26").Value Then
Range("B26, C26, D26, E26, F26, G26, H26").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("T26").Value = 0 Then
Range("B26, C26, D26, E26, F26, G26, H26, B28, C28").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 8420607
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
iRow = iRow + 1
iColumn = iColumn + 1
Loop
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
If Range("B18, B19").Value = "" Then
Range("B18,B19").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("C18, C19").Value = "" Then
Range("C18,C19").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("D18, D19").Value = "" Then
Range("D18,D19").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("E18, E19").Value = "" Then
Range("E18,E19").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("E18, E19").Value = "" Then
Range("E18,E19").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("F18, F19").Value = "" Then
Range("F18,F19").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("G18, G19").Value = "" Then
Range("G18,G19").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("H18, H19").Value = "" Then
Range("H18,H19").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("B28, B29").Value = "" Then
Range("B28,B29").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("C28, C29").Value = "" Then
Range("c28,c29").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("d28, d29").Value = "" Then
Range("d28,d29").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("e28, e29").Value = "" Then
Range("e28,e29").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("f28, f29").Value = "" Then
Range("f28,f29").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("g28, g29").Value = "" Then
Range("g28,g29").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("h28, h29").Value = "" Then
Range("h28,h29").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("D26, d27").Value = "" Then
Range("D26,D27").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("e26, e27").Value = "" Then
Range("e26,e27").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("f26, f27").Value = "" Then
Range("f26, f27").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("g26, g27").Value = "" Then
Range("g26, g27").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
If Range("h26, h27").Value = "" Then
Range("h26,h27").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
End If
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Range("Q6").Select
Application.ScreenUpdating = True
End Sub

You may also store information of your cell value with an Static variable, after the sub ends:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Value1 As Variant Static Value2 As Variant
Value1 = Range("B2005").Value
If Value1 <> Value2 Then
MsgBox "Cell " & Target.Address & " has changed."
End If
Value2 = Range("B2005").Value
End sub

You have to use a cell to keep track of previous value. In the below procedure "AnotherCell" is used for keeping the previous value and "FormulaCell" is where you have formula. Then use the below procedure on your worksheet code remember not in Workbook or Module page.
Private Sub Worksheet_Calculate()
If Range("AnotherCell") <> Range("FormulaCell").Value Then
Range("AnotherCell") = Range("Formula").Value
'Your Code Here
End If
End Sub

Check out this article on Events in Excel VBA
You can write code in the Worksheet_Change event procedure to take
some action depending on which cell was changed or based upon the
newly changed value. (The Worksheet_Change event might more properly
be called Worksheet_AfterChange since it is called after the cell(s)
has been changed

it works only if you have one cell that changes. If you have a table, and you don't know when and which cell changes, but you want to run a macro when anything in the table changes, and it is changed by formula.