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
Related
how to write code in vba if I want the another column to fill with yellow color when one column is not null?
For example:
if A1,A3,A8,A100 is not null:
fill background of B1,B3,B8,B100 into yellow color
If a loop is used would be great because my actual case have 7000 cells to fill instead of 4
Option Explicit
Sub ColorColA()
Dim ws As Worksheet
Dim lastrow As Long, cell As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
lastrow = ws.Range("B" & Rows.Count).End(xlUp).Row
For Each cell In ws.Range("A1:A" & lastrow)
If IsEmpty(cell) Then
cell.Offset(0, 1).Interior.Color = RGB(255, 255, 0) 'yellow
Else
cell.Offset(0, 1).Interior.Pattern = xlNone ' remove color
End If
Next
MsgBox lastrow & " rows scanned", vbInformation
End Sub
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:
I'm trying to find a VBA code that would highlight appropriate row within the range "A7:AD100" if a cell in the column "AB" has value "Elective."
Sub highlight()
Dim cell As Range
Range(Range("AB7"), Range("AB7").End(xlDown)).Select
For Each cell In Selection
If cell = "Elective" Then Cells.Range($A7, $AD7).Interior.ColorIndex = 10
Next cell
End Sub
Only rows 1, 11, 21, 23 are highlighted since they have Admit Type = "Elective". The rows highlighted only within the range "A:AD" (I don't want the whole row to be highlighted).
I found this code that works for me
Sub HighlightCells()
Dim rngMyCell As Range
Dim lngLastRow As Long
Application.ScreenUpdating = False
lngLastRow = Cells(Rows.Count, "AB").End(xlUp).Row
For Each rngMyCell In Range("AB7:AB" & lngLastRow)
If StrConv(rngMyCell, vbProperCase) = "Elective" Then
Range("A" & rngMyCell.Row & ":AD" & rngMyCell.Row).Interior.Color = RGB(240, 240, 240)
End If
Next rngMyCell
Application.ScreenUpdating = True
End Sub
My sheet look like :
I have a function to get index of the LAST empty cell in column A:
NextRow = Range("A" & Rows.Count).End(xlUp).Row + 1
This function works to write on second array (Type2).
But now, i would like a function to get index of the FIRST empty cell in column A. So i went to this website: Select first empty cell and i tried to adapt code but it's doesn't work:
If Array= "Type1" Then
Dim ws As Worksheet
Set ws = ActiveSheet
For Each cell In ws.Columns(1).Cells
If IsEmpty(cell) = True Then NextRow = cell: Exit For 'ERROR 1004
Next cell
End If
If Array= "Type2" Then 'It s works
NextRow = Range("A" & Rows.Count).End(xlUp).Row + 1
End If
ActiveSheet.Range("A" & NextRow) = "TEST"
Could you help me to adapt my code to have NextRow = IndexOf FIRST empty cell in A ?
You could just use the same method you did to get the last one.
NextRow = Range("A1").End(xlDown).Row + 1
I do this and it' works:
If Array= "Type1" Then
Dim ws As Worksheet
Set ws = ActiveSheet
For Each cell In ws.Columns(1).Cells
If IsEmpty(cell) = True Then
NextRow = cell.Row
Exit For
MsgBox NextRow
End If
Next cell
End If
If Array= "Type2" Then 'It s works
NextRow = Range("A" & Rows.Count).End(xlUp).Row + 1
End If
ActiveSheet.Range("A" & NextRow) = "TEST"
You should look bottom up for this.
And Find is better than xlUp.
Sub FindBlank()
Dim ws As Worksheet
Dim rng1 As Range
Set ws = ActiveSheet
Set rng1 = ws.Columns(1).Find("*", ws.[a1], xlFormulas, , xlByColumns, xlPrevious)
If Not rng1 Is Nothing Then
MsgBox "Last used cell is " & rng1.Address(0, 0)
Else
MsgBox ws.Name & " row1 is completely empty", vbCritical
End If
End Sub
I took a similar approach to some of the answers, but with the goal of repeatedly looking down the column until I could guarantee that there was no more populated cells below.
I turned this into a small function that I put in a standard module:-
Public Function getFirstBlankRowNumberOnSheet(sht As Worksheet, Optional startingRef As String = "A1") As Long 'may get more than 32767 rows in a spreadsheet (but probably not!)
Dim celTop As Range
Dim celBottom As Range
On Error Resume Next
Set celTop = sht.Range(startingRef)
Do
Set celBottom = celTop.End(xlDown)
Set celTop = celBottom.Offset(1) 'This will throw an error when the bottom cell is on the last available row (1048576)
Loop Until IsEmpty(celBottom.value)
getFirstBlankRowNumberOnSheet = celTop.Row
End Function
This will throw an error if there happens to be content in the row #1048576! The particulars of this are dependent on the Excel version I suppose in terms of maximum row cont allowed.
I have a text string that is using the ^ symbol as a delimiter.
I need to separate the text into new rows rather than new columns.
I need to create new rows to not overwrite the next line of data below it.
Is this possible without using a macro? I'm not against using one, I just wouldn't know where to start to write it.
Below is a pic of some sample data. The top part is how it's listed, and the bottom (in yellow) is how I would like it.
Using Excel 2010 on Windows 7 Pro.
Thanks to those that responded. A friend was able to help by providing the following code:
Sub Breakout()
Application.ScreenUpdating = False
LR = Cells(Rows.Count, 1).End(xlUp).Row
For r = LR To 2 Step -1
Set MyCell = Cells(r, 1)
Arry = Split(MyCell.Value, "^")
For c = 0 To UBound(Arry)
If c > 0 Then MyCell.Offset(c, 0).EntireRow.Insert
MyCell.Offset(c, 0) = Arry(c)
Next c
Next r
End Sub
Could try something like this:
Sub reArrange()
Dim inFirstRng As Range
Dim inRng As Range
Dim inCur As Variant
Dim outFirstRng As Range
Dim outCurRng As Range
Dim ws As Worksheet
'CHANGE ARGUMENT TO YOUR SHEET NAME
Set ws = Worksheets("Sheet2")
With ws
'CHANGE ARGUMENT TO WHATEVER THE FIRST CELL OR YOUR DATA INPUT IS IN COLUMN A
Set inFirstRng = .Range("A3")
Set inRng = .Range(inFirstRng, inFirstRng.End(xlDown))
'CHANGE ARGUMENT TO WHATEVER THE FIRST CELL OR YOUR DATA OUTPUT IS IN COLUMN A
Set outFirstRng = .Range("A9")
Set outCurRng = outFirstRng
End With
For Each cell In inRng.Cells
inCur = WorksheetFunction.Transpose(Split(cell.Value, "^"))
outCurRng.Resize(UBound(inCur), 1).Value = inCur
With ws
.Range("G" & outCurRng.Row & ":L" & outCurRng.Row).Value = _
.Range("G" & cell.Row & ":L" & cell.Row).Value
End With
Set outCurRng = outCurRng.Offset(UBound(inCur), 0)
Next cell
ws.Range("F" & outFirstRng.Row & ":F" & outCurRng.Row - 1).Value = 1
End Sub