Dear forum readers,
I have the following problem.
In the file I want to give each cell that has to different value than the cell in the previous column same row a color (blue).
In the example you see cell G41 has no color but has different value than F41.
Also, in A2 the correct number of colored cells must be displayed. This is now correct but column B should not be counted so that code needs to be changed.
So the current VBA code is almost correct but if there is a better code then this can be done, only I am not a code expert. So please provide complete then.
This is sheet DG-(28-16) and in sheet Data 28-16 there is the value which can be copied with copy & paste back into sheet DG-(28-16) for testing.
I am working with the Excel 2019 (NL) version, but ENG will also work I hope
With Regards,
FvdF
>>> use code - tags <<<
I have the following problem.
In the file I want to give each cell that has to different value than the cell in the previous column same row a color (blue).
In the example you see cell G41 has no color but has different value than F41.
Also, in A2 the correct number of colored cells must be displayed. This is now correct but column B should not be counted so that code needs to be changed.
So the current VBA code is almost correct but if there is a better code then this can be done, only I am not a code expert. So please provide complete then.
This is sheet DG-(28-16) and in sheet Data 28-16 there is the value which can be copied with copy & paste back into sheet DG-(28-16) for testing.
I am working with the Excel 2019 (NL) version, but ENG will also work I hope
With Regards,
FvdF
>>> use code - tags <<<
Code:
Sub Schema2816()
Call UnprotectActiveSheet
' KeepOnlyNeededRows
Dim ws As Worksheet
Dim Rng As Range
Dim LastRow As Long
Set ws = ActiveWorkbook.Sheets("DG-(28-16)")
LastRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
Set Rng = ws.Range("B4:B" & LastRow)
' filter and delete all but header row
With Rng
.AutoFilter Field:=1, Criteria1:="<>*2022*"
.Offset(0, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
' turn off the filters
ws.AutoFilterMode = False
' MoveRows
Rows("32:47").Cut
Rows(18).Insert
' Borders
Range("A18:H33").BorderAround _
LineStyle:=XlLineStyle.xlContinuous, _
Weight:=xlMedium
Range("B4:H4").Interior.Color = RGB(0, 255, 255)
' ColorRowsNotEquelGOV
nColour = 7
Dim cl As Range
For Each cl In Range("B4:H" & Cells(Rows.Count, "B").End(xlUp).Row)
If Not cl.Value Like "*GOV*" Then
If WorksheetFunction.CountIf(Range(Cells(cl.Row, "B"), cl), cl.Value) = 1 Then
nColour = nColour + 1
cl.Interior.Color = RGB(0, 255, 255)
End If
End If
Next cl
LastRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
ws.Range("A4:A" & LastRow).Formula = "=row()-3"
ws.Range("A2") = nColour
Call ProtectActiveSheet
' Call PDFActiveSheetNoPrompt
End Sub
Attachments
Last edited by a moderator: