I want to find min value that color value is not fill with red color with Vba code
my code is here:
Private Sub bidcanceled_Click()
Dim HLF As Range, finalHLF
Dim minNum As Double
Dim Lastrow As Integer
Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set HLF = Range("e2:e" & Lastrow)
Range("e2:e" & Lastrow).Select
minNum = WorksheetFunction.MIN(HLF)
finalHLF = HLF.Find(what:=minNum, Lookat:=xlWhole).Address
Range(finalHLF).Interior.Color = vbGreen
Range(finalHLF).Offset(, 3).Value = "bid canceled"
End Sub
the output must choose the cell = 41 and fill the color with green can any one help to solve that, when i run the code it's choose 37 and fill it with green ..i want it to select non color values and find the min number in that column
As per my comment, I would suggest to implement an AutoFilter on color:
Sample Data:
Sample Code:
Sub Test()
Dim Lr As Long, MinVal As Long
Dim Rng As Range
With Sheet1 'Change according to your sheets CodeName
'Retrieve last used row on column E
Lr = .Cells(.Rows.Count, 5).End(xlUp).Row
'Apply our filter of non-colored cells
Set Rng = .Range("E1:E" & Lr)
Rng.AutoFilter 1, , 12
'First check if any rows are filtered to prevent error on .SpecialCells and color the minimum
If Rng.SpecialCells(12).Count > 1 Then
MinVal = WorksheetFunction.min(Rng.SpecialCells(12))
Rng.SpecialCells(12).Find(MinVal, Lookat:=xlWhole).Interior.Color = vbGreen
Rng.SpecialCells(12).Find(MinVal, Lookat:=xlWhole).Offset(, 3).Value = "bid canceled"
End If
'Get rid of Filter
Rng.AutoFilter
End With
End Sub
Sample Result:
Related
I am processing a data set that has about 50 columns, and the same columns are always off by a factor of ten. So, I just want to hardcode the specific columns (starting with F here) and divide every cell in the column by 10. Right now I am getting a "Type Mismatch" error. The code is below:
Sub FixData()
Dim finalRow As Long
Dim rng As Range
Dim cell As Range
finalRow = Range("A100000").End(xlUp).Row
Set rng = Range("F1:F" & finalRow)
For Each cell In rng
cell.Value = cell.Value / 10
Next cell
End Sub
why loop when you can simply paste special and divide.
errors within the cells are ignored.
in vba, here is the code
Range("G10").Copy
Range("B2:E8").PasteSpecial Paste:=xlPasteValues, Operation:=xlDivide
Application.CutCopyMode = False
test if cell is an error and then test if it is a number prior to dividing:
Sub FixData()
Dim finalRow As Long
Dim rng As Range
Dim cell As Range
finalRow = Range("A100000").End(xlUp).Row
Set rng = Range("F1:F" & finalRow)
For Each cell In rng
If Not IsError(Cell) Then
If IsNumeric(cell) and cell <> "" Then
cell.Value = cDbl(cell.Value) / 10
End If
End If
Next cell
End Sub
I am trying to set the cell colors of a range of cells based on the data that's been inputted.
The row will change based on what row is currently active, but the columns will remain the same.
I want to change the cell color to black if the active cell is "N/A". I keep getting Run-Time Error 13: Type Mismatch. I'm trying to color columns D:F in whichever row is currently selected. My snip of code is below.
Sub black_out_range()
Dim wsC As Worksheet
Dim jobRange As Range
Dim jobRange As Range
Set wsC = Worksheets("Sheet1")
Set jobRange = Range("B10", Range("B10").End(xlDown))
jobRange.Select
If TypeName(Selection) = "Range" Then
For Each i In jobRange
i.Activate
If ActiveCell = "N/A" Then
With wsC
.Range(.Cells(4, i), .Cells(6, i)).Interior.Color = RGB(0, 0, 0)
End With
Thanks in advance!
It's usually best to try to avoid using select and activate in VBA, especially when you are trying to loop through a range
This code will look at the values in column b starting at row 10 (to the last row of data) and then color d-f black is the value in B is "N/A".
Sub black_out_range()
Dim last_row As Long
last_row = Range("B10").End(xlDown).Row()
For i = 10 To last_row
If Cells(i, 2).Value = "N/A" Then 'asumes you want to start looking at cell b10
Range("D" & i & ":F" & i).Interior.Color = RGB(0, 0, 0)
End If
Next i
End Sub
You did not answer my clarification question, so I will try assuming that you try dealing with the real error #N/A. If so, please try the next code. It also avoids selecting, which does not bring any benefit, only consumes Excel resources decreasing the code speed:
Sub black_out_range()
Dim wsC As Worksheet, lastR As Long, i As Long
Set wsC = Worksheets("Sheet1")
lastR = wsC.Range("B" & rows.count).End(xlUp).row() 'it returns the last cell even with gaps in the range
For i = 10 To lastR
If IsError(wsC.Range("B" & i).Value) Then
If wsC.Range("B" & i).Value = CVErr(2042) Then 'the error for '#N/A' type
wsC.Range("D" & i & ":F" & i).Interior.Color = RGB(0, 0, 0)
End If
End If
Next i
End Sub
But, if you really have a "N/A" in those cells, please use the next version:
Sub black_out_range_bis()
Dim wsC As Worksheet, lastR As Long, i As Long
Set wsC = Worksheets("Sheet1")
lastR = wsC.Range("B" & rows.count).End(xlUp).row()
For i = 10 To lastR
If wsC.Range("B" & i).Value = "N/A" Then
wsC.Range("D" & i & ":F" & i).Interior.Color = RGB(0, 0, 0)
End If
Next i
End Sub
I would like to change the color of certain text in the cells based on the values in another cells. I have tried using conditional formatting but it does not work since I only wanted to change the color of particular words in the cells. I have googled a few VBA codes as well but still could not find the right one. Is there any VBA Code to enable this?
As shown in the example below (see image), I want to highlight ONLY the dates in Column B and C that match the dates in Column G. The day should remain the same.
For information, the values in Column B and C are formatted as text and the values in G are formatted as date.
Before
and this is basically what I wish for.
After
I have modified code appropriately as per your requirement in the comment.
Sub Change_Text_Color()
Dim Find_Text, Cell, Cell_in_Col_G, LastCell_inColG As Range
Dim StartChar, CharLen, LastUsedRow_inRange, LastUsedRow_inColB, _
LastUsedRow_inColC As Integer
LastUsedRow_inColB = Sheet1.Cells(Rows.count, "B").End(xlUp).Row
LastUsedRow_inColC = Sheet1.Cells(Rows.count, "C").End(xlUp).Row
LastUsedRow_inRange = Application.WorksheetFunction. _
Max(LastUsedRow_inColB, LastUsedRow_inColC)
Set LastCell_inColG = Sheet1.Cells(Rows.count, "G").End(xlUp)
For Each Cell In Range(Sheet1.Cells(2, 2), Cells(LastUsedRow_inRange, 3))
For Each Cell_in_Col_G In Range(Sheet1.Cells(2, 7), LastCell_inColG)
CharLen = Len(Cell_in_Col_G.Text)
Set Find_Text = Cell.Find(what:=Cell_in_Col_G.Text)
If Not Find_Text Is Nothing Then
StartChar = InStr(Cell.Value, Cell_in_Col_G.Text)
With Cell.Characters(StartChar, CharLen)
.Font.Color = RGB(0, 255, 0)
End With
End If
Next
Next
End Sub
Please let me know your feedback on it.
Use Characters:
With Range("a1")
.Characters(Start:=1, Length:=4).Font.Color=0
.Characters(Start:=5, Length:=10.Font.Color=255
End With
colours the first four letters black and the next ten in red.
Ref:
https://learn.microsoft.com/en-us/office/vba/api/excel.characters
I find filtering works well in these scenarios. Assuming that the format of your sheet is as it is in your sample sheets, try the code below:
Sub MarkDatesInCells()
Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet3") '<- Change to the sheet name
Dim iLRToHighlight As Long, iStartChar As Long, iC As Long, iLR As Long
Dim oHighlightRng As Range, oUpdateRng As Range, oRng As Range
Dim sColName As String
' Turn off updating
Application.ScreenUpdating = False
Application.EnableEvents = False
With oWS
' Clear autofilter if exists
If .AutoFilterMode Then .AutoFilterMode = False
' Loop through all values specified in column G
iLRToHighlight = .Range("G" & .Rows.Count).End(xlUp).Row
For Each oHighlightRng In .Range("G2:G" & iLRToHighlight)
' Loop through column B and C
For iC = 2 To 3
' Set autofilter based on the value in column G
.UsedRange.AutoFilter iC, "=*" & oHighlightRng.Value
' Loop through all visible rows
iLR = .Cells(.Rows.Count, iC).End(xlUp).Row
If iLR > 1 Then
sColName = Left(Replace(.Cells(1, iC).Address, "$", ""), 1)
Set oUpdateRng = .Range(sColName & "2:" & sColName & iLR).SpecialCells(xlCellTypeVisible)
' Update each cell text
For Each oRng In oUpdateRng
iStartChar = InStr(1, oRng.Value, "- ", vbTextCompare) + 2
oRng.Characters(Start:=iStartChar, Length:=Len(oHighlightRng.Value)).Font.Color = 255
Next
End If
.AutoFilterMode = False
Next
Next
End With
' Turn on updating
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
EDIT
Based on your requirement to have this solution for a sheet with a table connected to a database, try the below code. I don't have a database that I can test the below code on so you might have to tinker with it a bit to get it right (i.e. the text that is highlight)
Sub MarkDatesInCellsInATable()
Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet4") '<- Change to the sheet name
Dim iLRToHighlight As Long, iStartChar As Long, iC As Long, iLR As Long
Dim oHighlightRng As Range, oUpdateRng As Range, oRng As Range
Dim sColName As String
Dim oTable As ListObject: Set oTable = oWS.ListObjects("Table_ExceptionDetails.accdb") '<- Change to the table name
Application.ScreenUpdating = False
Application.EnableEvents = False
With oWS
' Reset autofilter
oTable.Range.AutoFilter
' Loop through all values specified in column G
iLRToHighlight = .Range("G" & .Rows.Count).End(xlUp).Row
For Each oHighlightRng In .Range("G2:G" & iLRToHighlight)
' Loop through column B and C
For iC = 2 To 3
' Set autofilter based on the value in column G
oTable.Range.AutoFilter iC, "=*" & oHighlightRng.Value & "*"
' Loop through all visible rows
iLR = .Cells(.Rows.Count, iC).End(xlUp).Row
If iLR > 1 Then
sColName = Left(Replace(.Cells(1, iC).Address, "$", ""), 1)
Set oUpdateRng = .Range(sColName & "2:" & sColName & iLR).SpecialCells(xlCellTypeVisible)
' Update each cell text
For Each oRng In oUpdateRng
iStartChar = InStr(1, oRng.Value, "- ", vbTextCompare) + 2
oRng.Characters(Start:=iStartChar, Length:=Len(oHighlightRng.Value)).Font.Color = 255
Next
End If
oTable.Range.AutoFilter
Next
Next
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
I have a range of data, with CASE ID's in Column A, and Issues (1 through 10, or Columns B through K) in Columns B onwards.
Once certain issues are ruled out as 'normal', they would be removed from the Issues sheet based on their respective column. For ex: CASE ID #25, Issue 4 is ruled OK, then it would be deleted from Row 25, Column 5 (or Column E) but the CASE ID would remain.
The goal is that by doing this check after the fact, it may leave certain rows entirely blank, from Column B onwards (since the CASE ID would already be there.)
My code doesn't function successfully. Once run, it highlights several rows that are not entirely blank in the target range.
I'm trying to pinpoint rows in the range B2:P & lastrow where the entire row is blank, and then highlight these rows and subsequently delete them.
Code:
Public Sub EmptyRows()
lastrow = Sheets("Issues").Cells(Rows.Count, "A").End(xlUp).row
On Error Resume Next
Sheets("Issues").Activate
For Each rng In Range("B2:P" & lastrow).Columns
rng.SpecialCells(xlCellTypeBlanks).EntireRow.Interior.ColorIndex = 11
'rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Next rng
Application.ScreenUpdating = True
End Sub
The purpose of first highlighting is to test the code works. If successful, they would be deleted entirely.
Your description says Columns B through K, but your code has B through P...
You can do it like this (adjust resize for actual columns involved):
Public Sub EmptyRows()
Dim lastRow As Long, sht As Worksheet, c As Range, rngDel As Range
Set sht = Sheets("Issues")
For Each c In sht.Range(sht.Range("A2"), sht.Cells(Rows.Count, 1).End(xlUp)).Cells
If Application.CountA(c.Offset(0, 1).Resize(1, 10)) = 0 Then
'build range to delete
If rngDel Is Nothing Then
Set rngDel = c
Else
Set rngDel = Application.Union(rngDel, c)
End If
End If
Next c
'anything to flag/delete ?
If Not rngDel Is Nothing Then
rngDel.EntireRow.Interior.ColorIndex = 11
'rngDel.EntireRow.Delete '<< uncomment after testing
End If
End Sub
Once run, it highlights several rows that are not entirely blank in the target range.
This is because you are selecting all blanks, instead of only rows where the entire row is blank.
See the code below
Public Sub EmptyRows()
With Sheets("Issues")
lastrow = .Cells(Rows.Count, "A").End(xlUp).row
Dim rng as Range
For Each rng In .Range("B2:B" & lastrow)
Dim blankCount as Integer
blankCount = Application.WorksheetFunction.CountA(rng.Resize(1,.Range("B:P").Columns.Count))
If blankCount = .Range("B" & lastRow & ":P" & lastRow).Columns.Count Then
Dim store as Range
If store Is Nothing Then Set store = rng Else: Set store = Union(rng, store)
End If
Next rng
End With
store.EntireRow.Interior.ColorIndex = 11
'store.EntireRow.Delete
End Sub
Gathering the ranges first and then modified them (changing color or deleting) will help to execute the code faster.
Here is another approach, using CountA
For Each cell In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Dim rng As Range
Set rng = Range("A" & cell.Row & ":" & "P" & cell.Row)
If Application.WorksheetFunction.CountA(rng) = 1 Then
rng.EntireRow.Interior.ColorIndex = 11
End If
Next cell
The following code is doing the following:
Starting from A1, it searches for the last filled cell and selects
the cell right after it.
After selecting the first available blank cell it selects the entire row
The entire row is then colored with color index 16.
Here you go:
Sub Macro1()
Range("A1").End(xlDown).Offset(1, 0).Select
Range(Selection, Selection.End(xlToRight)).Select
With Selection.Interior
.ColorIndex = 16
End With
End Sub
This works great but I am having difficulty selecting only columns A to H within that row. I don't want to select the entire row.
Can someone please help me? I keep getting End With errors and not sure how to fix it :S
Thank you very much for your time and consideration!
That is too much selecting! How about
Sub Macro1()
currentRow = Range("A1").end(xldown).offset(1,0).row
Range(cells(currentRow, 1), cells(currentRow,8)).Interior.ColorIndex = 16
cells(currentRow,1)= " "
End Sub
Does that work?
you can set a range for your selection, also here is another method to find last row from the end of the column (version 1) - the (Rows.Count,1) represents column A (Rows.Count,2) would represents column B and so on...
this is version one: start looking for empty row from the end of column A:
Dim rowNum As Integer
rowNum = Cells(Rows.Count, 1).End(xlUp).Row + 1
Dim rng As Range
Set rng = Range(Cells(rowNum, 1), Cells(rowNum, 8))
rng.Interior.ColorIndex = 16
this is version two: start looking for empty row from the start (row 1) of column A:
Dim rowNum As Integer
rowNum = Range("A1").End(xlDown).Offset(1, 0).Row
Dim rng As Range
Set rng = Range(Cells(rowNum, 1), Cells(rowNum, 8))
rng.Interior.ColorIndex = 16
Try this:
'Declare Variables
Dim rowNum as integer
Dim YourRange as range
'Find last row by counting cells not empty and adding 1
'Assumes that all cells from A1 down are filled. Change the +1 accordingly if not
rowNum = worksheetfunction.counta(activesheet.columns(1))+1
'Set range object to column A through H of your row number
Set YourRange = Activesheet.Range("A" & rowNum & ":H" & rowNum)
'Set interior color of the rnage object instead of using Selection
YourRange.interior.colorindex=16