I have wrote a code and I want to use conditional formatting to highlight each cell within a row of dates between two dates of Cell C8 , D8 and Percentage B8.
I have added a below pictures where i have been using Conditional Formatting but i want to perform this task through VBA.
Below picture is highlighting the cells based on dates of C8 , D8 and its progress B8.
I want to add one more thing that Code will popup the color in between dates which is available in cell B4
I have wrote this piece of code but unable to complete this if someone could help to complete it. I will really appreciate the help.
Sub updcolor()
Dim rngDates As Range
Dim startd As Range
Dim endd As Range
Dim prog As Range
Dim color As Range
Set startdt = Sheet1.Range("C8")
Set enddt = Sheet1.Range("D8")
Set prog = Sheet1.Range("B8")
Set color = Sheet1.Range("B4")
Set rngDates = Sheet1.Range("I4:BJ4")
Dim rngDateCell As Range
For Each rngDateCell In rngDates.Cells
If Sheet1.Cells(rngDateCell.Row, 4).Value <= rngDateCell.Value And _
Sheet1.Cells(rngDateCell.Row, 4).Value >= rngDateCell.Value Then
rngDateCell.Interior.ColorIndex = Sheet1.range("B4")
End If
Next rngDateCell
End Sub
I assume row 4 has dates although you only show the day number.
Option Explicit
Sub updcolor()
Const DATE_RNG As String = "G4:BJ4"
Dim ws As Worksheet, r As Long, pcent As Single
Dim rng As Range, color As Integer
Set ws = Sheet1
color = Sheet1.Range("B4").Interior.ColorIndex
Dim dtStart As Date, dtEnd As Date, dtEndBar As Date
Dim dur As Integer
' scan down sheet
For r = 8 To 11
pcent = ws.Cells(r, "B")
dtStart = ws.Cells(r, "C")
dtEnd = ws.Cells(r, "D")
dur = DateDiff("d", dtStart, dtEnd) + 1
dtEndBar = DateAdd("d", Int(dur * pcent) - 1, dtStart)
'ws.Cells(r, "A") = dtEndBar
' scan across dates
For Each rng In ws.Range(DATE_RNG)
If rng >= dtStart And rng <= dtEndBar Then
ws.Cells(r, rng.Column).Interior.ColorIndex = color
Else
ws.Cells(r, rng.Column).Interior.ColorIndex = xlNone
End If
Next
Next
End Sub
Related
I've got the following table in an Excel sheet, called Teams;
TEAM
TLA
C
COLOUR
Ferrari
FER
FER
EE161F
Renault
REN
REN
00B0F0
WilliamsF1
WIL
WIL
000066
The value in the C column is taken directly from the TLA column with =[#TLA]. The value in the COLOUR column is what I want the text and background colour set to when I run the macro. I also want this conditional formatting to apply to the entire column and not just that specific cell. I've got the first part working with the following sub;
Sub SetConditionalFormatting()
Dim rng As Range
Dim row As Range
Dim position As Long
Dim colourColumnIndex As Integer
Dim tlaColumnIndex As Integer
Set rng = Range("Teams")
colourColumnIndex = rng.ListObject.ListColumns("COLOUR").Range.Column
tlaColumnIndex = rng.ListObject.ListColumns("C").Range.Column
For Each row In rng
Dim colorCell As Range
Dim tlaCell As Range
Dim hex As String
Dim color
Set colorCell = Cells(row.row, colourColumnIndex)
Set tlaCell = Cells(row.row, tlaColumnIndex)
hex = colorCell.Value
color = RGB(Application.Hex2Dec(Left(hex, 2)), Application.Hex2Dec(Mid(hex, 3, 2)), Application.Hex2Dec(Right(hex, 2)))
tlaCell.FormatConditions.Delete
tlaCell.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:=tlaCell.Value
tlaCell.FormatConditions(1).Interior.color = color
tlaCell.FormatConditions(1).Font.color = color
tlaCell.FormatConditions(1).Borders.color = RGB(19, 21, 29)
tlaCell.FormatConditions(1).StopIfTrue = False
Next
End Sub
However this only applies the conditional formatting to that specific cell (so $C$2 for example). What I need is the formatting to be applied to $C$2:$C$4, like it would if I'd select the entire C column and then manually copy/paste the formatting to other tables.
I've added tlaCell.FormatConditions(1).ModifyAppliesToRange Range("Teams[C]") as a final call as an attempt to make this work, but instead of applying formatting once for reach row to the entire column, it applies the formatting as seen in the first screenshot. What I need instead is for the "applies to" range to be set as in the second screenshot. Any idea how I can accomplish this?
Edit: managed to get it to work thanks to Foxfire's suggestion, this is the code I ended up with;
Sub SetConditionalFormatting()
Dim rng As Range
Dim row As Range
Dim position As Long
Dim colourColumnIndex As Integer
Dim tlaColumnIndex As Integer
Dim formattingColumn As Range
Set rng = Range("Teams")
Dim colours
Set colours = CreateObject("Scripting.Dictionary")
colourColumnIndex = rng.ListObject.ListColumns("COLOUR").Range.Column
tlaColumnIndex = rng.ListObject.ListColumns("C").Range.Column
Set formattingColumn = Range("Teams[C]")
formattingColumn.FormatConditions.Delete
For Each row In rng
Dim colorCell As Range
Dim tlaCell As Range
Dim hex As String
Set colorCell = Cells(row.row, colourColumnIndex)
Set tlaCell = Cells(row.row, tlaColumnIndex)
hex = colorCell.Value
If Not colours.Exists(tlaCell.Value) Then
colours.Add Key:=tlaCell.Value, Item:=hex
End If
Next
Dim tla As Variant
Dim index As Integer
index = 1
For Each tla In colours.Keys
hex = colours(tla)
Dim color
color = RGB(Application.Hex2Dec(Left(hex, 2)), Application.Hex2Dec(Mid(hex, 3, 2)), Application.Hex2Dec(Right(hex, 2)))
formattingColumn.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:=tla
formattingColumn.FormatConditions(index).Interior.color = color
formattingColumn.FormatConditions(index).Font.color = color
formattingColumn.FormatConditions(index).Borders.color = RGB(19, 21, 29)
formattingColumn.FormatConditions(index).StopIfTrue = False
index = index + 1
Next
End Sub
I'll see if I can clean it up a bit, but this works how it's supposed to.
I made an example based on your data using a dictionary.
Sub test()
Dim i As Long
Dim LR As Long
Dim FormatRng As Range
Dim Dic As Object
Dim MyKey As Variant
Dim hex As String
Dim Mycolor As Variant
Set Dic = CreateObject("Scripting.Dictionary")
LR = Range("A" & Rows.Count).End(xlUp).Row 'last used row in column A
Set FormatRng = Range("B2:B" & LR) 'the range where I want to apply my CF rules
FormatRng.FormatConditions.Delete
For i = 2 To LR '2 is the first row where my data is
'loop to create a Dicionary of unique items of C,COLOUR values
If Dic.Exists(Range("C" & i).Value) = False Then Dic.Add Range("C" & i).Value, Range("D" & i).Value
Next i
'loop trough dictionary to apply cf rules to FormatRng
i = 1
For Each MyKey In Dic.Keys
hex = Dic(MyKey)
Mycolor = RGB(Application.Hex2Dec(Left(hex, 2)), Application.Hex2Dec(Mid(hex, 3, 2)), Application.Hex2Dec(Right(hex, 2)))
With FormatRng
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:=MyKey
.FormatConditions(i).Interior.Color = Mycolor
.FormatConditions(i).Font.Color = vbWhite
.FormatConditions(i).Borders.Color = RGB(19, 21, 29)
.FormatConditions(i).StopIfTrue = False
End With
i = i + 1
Next MyKey
Set Dic = Nothing
Set FormatRng = Nothing
End Sub
The output I get:
Excel VBA Dictionary – A Complete
Guide
Excel highlight cells with the same value in colors
I need a macro that will color all duplicate cells with colors,
I need to color the cells in different colors, to Cell A2 and Cell A3 can have the same value like 50, and Cell A4 and A5 can have the value of 60, And Cell A7,A8 and A9 can have tha value of 40, or Cell A11, A15 and A20 can have tha value of 250.
I need the colors to not be the same if the value is different so Cells A2 and A3 can be yellow if the value is duplicate , then Cell A4 and A5 can be Orange, Cells A7, A8 and A9 can be yellow.
The problem is that it I can have an Excel files from 10 cells to 600 cells, So It can take forever to do manually.
I have a macro that can color in this way, but I need to be able to read tha value i the colored cells, something my macro can't do.
Is it possible to do something like this in VBA?
VBA Code:
Dim ws As Worksheet
Dim clr As Long
Dim rng As Range
Dim cell As Range
Dim r As Range
Set ws = ThisWorkbook.Sheets(ActiveSheet.Name)
Set rng = ws.Range("A2:a" & Range("A" & ws.Rows.Count).End(xlUp).Row)
With rng
Set r = .Cells(.Cells.Count)
End With
rng.Interior.ColorIndex = xlNone
clr = 3
For Each cell In rng
If Application.WorksheetFunction.CountIf(rng, cell) > 1 Then
'addresses will match for first instance of value in range
If rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False, After:=r).Address = cell.Address Then
'set the color for this value (will be used throughout the range)
cell.Interior.ColorIndex = clr
clr = clr + 1
Else
'if not the first instance, set color to match the first instance
cell.Interior.ColorIndex = rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False, After:=r).Interior.ColorIndex
End If
End If
Next
End Sub
If all you want to do is have an alternating color like in the picture, you only need to change the row clr = clr + 1 to something like the following.
If clr = 44 Then
clr = 45
Else
clr = 44
End If
Those are an estimation of the color in the picture. You also want to change clr = 3 to clr = 44 or whatever color you and up using.
If the numbers are sorted ascending or descending (like in your image) then you can do this much faster than using the find method.
Option Explicit
Public Sub ColorDuplicatesAlternate()
Dim ws As Worksheet ' define your sheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long ' find last used row
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim DataRange As Range ' read data range
Set DataRange = ws.Range("A1", "A" & LastRow + 1)
Dim DataValues() As Variant ' read data into array for fast processing
DataValues = DataRange.Value
Dim iStart As Long
iStart = 1
Dim BlockValue As Variant
Dim IsEven As Boolean
Dim EvenBlocks As Range
Dim OddBlocks As Range
Dim CurrentBlock As Range
Dim iRow As Long
For iRow = LBound(DataValues) + 1 To UBound(DataValues) ' loop through all data and find blocks, collect them in even and odd numbered blocks for alternate coloring
If BlockValue <> DataValues(iRow, 1) Then
If iRow - iStart > 1 Then
Set CurrentBlock = DataRange.Cells(iStart, 1).Resize(RowSize:=iRow - iStart)
If IsEven Then
If EvenBlocks Is Nothing Then
Set EvenBlocks = CurrentBlock
Else
Set EvenBlocks = Union(EvenBlocks, CurrentBlock)
End If
Else
If OddBlocks Is Nothing Then
Set OddBlocks = CurrentBlock
Else
Set OddBlocks = Union(OddBlocks, CurrentBlock)
End If
End If
IsEven = Not IsEven
End If
iStart = iRow
BlockValue = DataValues(iRow, 1)
End If
Next iRow
' color all even and odd blocks alternating
EvenBlocks.Interior.Color = vbRed
OddBlocks.Interior.Color = vbGreen
End Sub
Currently, I'm trying to figure a way to look down a single column to find a specific criterion and in this case, I want to find dates that are less than 4/16/20. Once that criteria is met, I want to SUM the cell below for all met criteria in that column. This is an image of my dataset
.
After doing some googling the closest I found was the code below which leads me to the idea that change information after offset to compute what I want.
Using "If cell contains" in VBA excel
Sub AddDashes()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("RANGE TO SEARCH")
For Each cel In SrchRng
If InStr(1, cel.Value, "TOTAL") > 0 Then
cel.Offset(1, 0).Value = "-"
End If
Next cel
End Sub
Not sure if I'm on the right track. It would also be nice If I would be able to amend code to check a range vs 1 column, thanks.
In this example you need to select the range of dates (1 row at a time only) to run the code. This also allows you to input the date (I'm assuming it changes over time so this should be helpful)
Sub SumByDate()
Dim DateRange As Range
Dim c As Range
Dim d As Range
Dim SearchDateInput As String
Dim SearchDate As Date
Set DateRange = Application.InputBox("Select a range", "Get Range", Type:=8) 'Select Date Range
SearchDateInput = Application.InputBox("Enter A Date") 'enter as mm/dd/yyyy
SearchDate = DateValue(SearchDateInput) 'this converts date entered as string to date format
For Each c In SrchRng 'for each date in list of dates
Set d = c.Offset(1, 0) 'pionts out cells to sum- in this case the cell beneath the date
If c < SearchDate Then 'if date is less than input date
Sum = Sum + d 'sum the date if true
End If
Next c 'goes to next date in row
DateRange.Cells(1, 1).Offset(2, -1) = Sum 'inputs all summed values into cell that is two down, one to the left of first date cell
End Sub
Sub SumByDate()
Dim SrchRng As Range
Dim c As Range
Dim d As Range
Dim lCol As Long
Dim ColLtr As String
Dim SearchDate As Date
lCol = Cells(2, Columns.Count).End(xlToLeft).Column
ColLtr = Split(Cells(1, lCol).Address, "$")(1)
Set SrchRng = Range("B2:" & ColLtr & "2")
SearchDate = DateValue("04/16/2020")
For Each c In SrchRng
Set d = c.Offset(1, 0)
If c < SearchDate Then
Sum = Sum + d
End If
Next c
Range("A4") = Sum
End Sub
I have a variety of calibration tests. I keep all different types and their dates in one worksheet "wsCAL"
I want to populate the userform with the most recent date of one specific type of test, which is stored in Column C in wsCAL.
In theory, I want VBA to go to wsCAL, look thru column C and find all instances of one test type, find the most recent date(or MAX) in column B of those instances, then populate my userform with that date.
I've tried using the rangeCAL = .Find() function to find all instances of a test type in column C. This part works just fine. However, the application.worksheetfunction.Max(rangeCAL) I try to use fails. I'm guessing it is because that application function only works with worksheet ranges and not Find() ones. I'm struggling with taking my rangeCAL cells, making an array, then finding the most recent date (the MAX) of those.
Private Sub UserForm_Initialize() 'Upon opening the userform
Set wb = ThisWorkbook
Set wsHOME = wb.Worksheets("Home")
Set wsCAL = wb.Worksheets("Bottle Calibrations")
Set wsC1T1 = wb.Worksheets("C1T1")
'Last Calibration Date
Label27.Caption = vbNullString
With wsCAL
Dim Cell As Range
Dim myArray As Date
Dim i As Integer
Dim rangeCAL As Range
Dim rangeDateCAL As Date
i = 0
Set rangeCAL = Range("C:C").Find(What:=tank, LookAt:=xlWhole)
If Not rangeCAL Is Nothing Then
For Each Cell In rangeCAL
myArray(i) = .Range(rangeCAL.Row, "A").Value
i = i + 1
Next
Else
MsgBox "Error: no previous Calibration dates loaded."
End If
rangeDateCAL = Application.WorksheetFunction.Max(myArray)
rangeDateCAL = Format(rangeDateCAL, "yymmdd")
End With
Label27.Caption = rangeDateCAL
I keep getting the error message
"Expected array"
as soon as I get to line:
myArray(i) = .Range(rangeCAL.Row, "B").Value
UPDATE:
Label27.Caption = vbNullString
With wsCAL
Dim Cell As Range
Dim myArray(1 To 5) As Date
Dim i As Long
Dim temp As Date
Dim rangeCAL As Range
Dim rangeDateCAL As Date
i = 1
Set rangeCAL = wsCAL.Range("C1", Range("C1").End(xlDown).Address)
For Each Cell In rangeCAL
If Cell <> "" Then
If Cell.Value = tank Then
temp = wsCAL.Cells(Cell.Row, "B").Value
myArray(i) = temp
i = i + 1
End If
End If
Next
rangeDateCAL = Application.WorksheetFunction.Max(myArray)
rangeDateCAL = Format(rangeDateCAL, "yymmdd")
End With
Label27.Caption = rangeDateCAL
I implemented this change after reading your comments. This code runs, but it fills Label27.Caption with 11/22/4613 instead of the intended 11/7/2019.
I'm assuming the date value is being altered at the MAX function step, but I'm not sure what else I can change.
For Each Cell In rangeCAL
If Cell.Text <> vbNullString Then
If Cell.Text = tank Then 'assuming tank is declared a string
If tempDate < wsCAL.Cells(Cell.Row, "B").Value Then
tempDate = wsCAL.Cells(Cell.Row, "B").Value
End If
End If
End If
Next
Label27.Caption = Format(tempDate, "yymmdd")
This is what I implemented, per SmileyFTW's suggestion. Far simpler than anticipated. Works as intended though. Thank you SmileyFTW, and the others who commented with help.
Label27.Caption = vbNullString
With wsCAL
Dim Cell As Range
Dim i As Date
Dim temp As Date
Dim rangeCAL As Range
temp = 0
Set rangeCAL = wsCAL.Range("C1", Range("C1").End(xlDown).Address)
For Each Cell In rangeCAL
If Cell <> vbNullString Then
If Cell.Value = tank Then
i = wsCAL.Cells(Cell.Row, "B").Text
If i > temp Then
temp = i
End If
End If
End If
Next
End With
Label27.Caption = temp
I'm trying to Extract Products Sales From Different Sheets depends on DATES( Between Two Dates), In the mainsheet, I have Two Columns : A for Dates; B for Sales Numbers. I'm new to VBA and trying to write code from learnt Youtube Videos, So far I can be able retrieve Only Column A values i.e, Only Dates, But I could not get the Sales values along with the Dates. I'm writing the Code Down here, Could you please check it once and let me know where and what exactly the mistake arise, your Suggestion Could helpful to me. Thank you in Advance. :)
Private Sub CommandButton1_Click()
Dim sh As Worksheet, Psh As String, x As Date, y As Date
Sheet8.Columns("A").NumberFormat = "m/d/yyyy"
Psh = Me.Shproducts ' Shproducts is Command Button Name
Set sh = Worksheets(Psh)
x = CDate(Me.TextBox1) ' Start Date
y = CDate(Me.TextBox2) ' End Date
Dim i As Long, Myrange As Range, Lastrow As Long
For i = 3 To sh.Range("F" & Rows.Count).End(xlUp).Row
If sh.Cells(i, 1) >= x And sh.Cells(i, 1) <= y Then
Sheet8.Range("A1000").End(xlUp).Offset(1, 0) = sh.Cells(i, 1)
Sheet8.Range("B1000").End(xlUp).Offset(1, 0) = sh.Cells(i, 2)
End If
Next i
End Sub
i haven't tested it, but you might want to do something like this. so this is based on your code:
Private Sub CommandButton1_Click()
Dim sh As Worksheet, Psh As String, x As Date, y As Date
Dim i As Long, Myrange As Range, Lastrow As Long
Dim destinationRange As Range, c As Range, sourceRange As Range
Dim counter As Long
Dim currentDate As Date, currentSales As Double
Sheet8.Columns("A").NumberFormat = "m/d/yyyy"
Psh = Me.Shproducts ' Shproducts is Command Button Name
Set sh = Worksheets(Psh)
x = CDate(Me.TextBox1) ' Start Date
y = CDate(Me.TextBox2) ' End Date
Set destinationRange = Sheet8.Range("A100000").End(xlUp).Offset(1, 0)
Set sourceRange = Range(sh.Range("F3"), sh.Range("F3").End(xlDown))
For Each c In sourceRange
currentDate = c.Value
currentSales = c.Offset(0, 1).Value
If currentDate >= x And currentDate <= y Then
destinationRange.Offset(counter, 0).Value = currentDate
destinationRange.Offset(counter, 1).Value = currentSales
counter = counter + 1
End If
Next i
End Sub