I am trying to change the font color of the cell row label to red if the row grand total is >130,000. The first part of the assignment entailed changing the color of the font in each cell with a value over 12000 - The code I have right now correctly colors the cells but does not turn the appropriate cell red (the cell in col A corresponding to the row it is iterating through to get a total). Any help would be appreciated, I am new to Excel VBA!
This is the code I have currently:
Option Explicit
Sub Question5()
Dim rng As Range
Dim cell As Range
Dim total As Integer
Dim i As Integer
Set rng = Range("B2", "M41")
For Each cell In rng
If cell.Value >= 12000 Then _
cell.Font.ColorIndex = 5
Next cell
Dim monthlysum As Integer
For Each Row In Range("B2", "M41")
Set monthlysum = 0
For Each cell In Row
monthlysum = cell.Value + monthlysum
Next cell
If monthlysum > 130000 Then _
Range("A" & rowNum).Select
Range("A" & rowNum).Font.Color = vbRed
Next Row
End Sub
Try this - fixes commented inline
Option Explicit
Sub Question5()
Dim rng As Range, Row As Range, cell as Range
Dim monthlySum as Long 'use Long not Integer
For Each Row In ActiveSheet.Range("B2:M41").Rows 'need to specify .Rows otherwise defaults to .Cells
monthlySum = 0
For Each cell in Row.Cells
with cell
if .Value >= 12000 Then cell.Font.ColorIndex = 5
monthlySum = monthlySum + .Value
End With
Next cell
if monthlySum > 130000 Then Row.Entirerow.cells(1).Font.color=vbRed
Next Row
End Sub
Related
Hi im trying to create a function in VBA which scans the top row and inserts a filter on a particular cell in the third row if the corresponding cell in the top row contains a value, if a cell is empty then it should skip to the next cell. The third row will be a header row.
Here is some code:
Sub FilterRefresh()
Dim i As Long, lastCol As Long
Dim rng As Range, cell As Range
Dim wSheet As Worksheet
Set wSheet = Worksheets("Machining")
'find the last column in row one
lastCol = wSheet.Cells(1, Columns.Count).End(xlToRight).Column 'xlToLeft
'set range from A1 to last column
Set rng = wSheet.Range(Cells(1, 1), Cells(1, lastCol)) 'will be a higher cell range
'Outline the autofilter field hierarchy
i = 1
For Each cell In rng
If cell.Value <> "" Then
wSheet.Cells(cell.row + 2, i + 1).AutoFilter Field:=i, Criteria1:=cell.Value
i = i + 1
End If
Next cell
End Sub
Try this:
For Each cell In rng
If cell.Value <> "" Then
wSheet.Cells(cell.Row + 2, cell.Column).AutoFilter Field:=cell.Column, Criteria1:=cell.Value
End If
Next cell
I have a range of values, I want to find the MIN, then highlight the row of this Min value.
Sub worstcase()
Set Rng = .Range("H44:H54")
worstcase = Application.WorksheetFunction.Min(Rng)
Debug.Print worstcase
How can I highlight rows based on variable worstcase?
I have my static range, and find the min value, but now I need to highlight the row of the worstcase variable.
Highlight Row With Found Criteria
The code is highlighting each row where the minimum was found. Use Exit For to highlight only the first found.
The Code
Sub worstcase()
Dim worstcase As Double ' Long for whole numbers.
Dim rng As Range
Dim cell As Range
With Worksheets("Sheet1")
Set rng = .Range("H44:H54")
worstcase = Application.WorksheetFunction.Min(rng)
Debug.Print worstcase
For Each cell In rng
If cell.Value = worstcase Then
cell.EntireRow.Interior.ColorIndex = 3 ' Hightlight whole row.
'cell.Interior.ColorIndex = 5 ' Hightlight only cell.
'Exit For ' To highlight only the first found row.
End If
Next
End With
End Sub
EDIT:
Sub worstcase()
Const cFirst As Variant = "H"
Const cLast As Variant = "Q"
Dim worstcase As Double ' Long for whole numbers.
Dim rng As Range
Dim cell As Range
With Worksheets("Sheet1")
Set rng = .Range("H44:H54")
worstcase = Application.WorksheetFunction.Min(rng)
Debug.Print worstcase
For Each cell In rng
If cell.Value = worstcase Then
.Range(.Cells(cell.Row, cFirst), .Cells(cell.Row, cLast)) _
.Interior.ColorIndex = 3 ' Hightlight cells.
'Exit For ' To highlight only the first found cells.
End If
Next
End With
End Sub
You could do it thus.
Won't work though if you have a repeated minimum.
Also you could use conditional formatting and avoid VBA.
Sub worstcase()
Dim Rng As Range, worstcase, i As Long
Set Rng = Range("H44:H54")
With Rng
worstcase = Application.WorksheetFunction.Min(.Cells)
i = Application.Match(worstcase, .Cells, 0)
.Cells(i).EntireRow.Interior.Color = vbRed
End With
End Sub
Create a conditional formatting rule based on the following formula.
=$H44=min($H$44:$H$54)
This VBA will create a CFR for rows 44:54.
With worksheets("sheet1").range("44:54")
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=$H44=min($H$44:$H$54)"
.FormatConditions(.FormatConditions.Count).Interior.Color = vbred
End With
Goal: Have the column header of any text in red be represented in column F of the same row as the text.
Problem: Code currently references active row, and for some reason copies F2 (which is written in red). I know the code currently would be attempting to copy/paste over a cell a few times, and I'll work that out later.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, ActiveCell.Column).Copy
Range("F" & (ActiveCell.row)).Select
ActiveSheet.Paste
End If
Next cell
Next row
End Sub
Not sure if I follow your logic. Your problem is that you reference active cell but you are not defining it or changing it other than through the pasting. I think you mean to reference cell (?)
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, cell.Column).Copy Range("F" & cell.row)
End If
Next cell
Next row
End Sub
You are never changing the active cell, so the copy command is always called on row 2 of the active cell, which much be in the F column. I changed the code below to fix the issue.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet ' this should be improved to point at the correct worksheet by name
Set rng = ws.Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
cell.Copy
ws.Range("F" & (cell.row)).PasteSpecial
End If
Next cell
Next row
End Sub
I'm trying to count all the cells in a column that have values above the active cell excluding the header and excluding the cell immediately above the active cell.
For example if I have a column
1
5
4
N/A N/A
4
current cell
I want the current cell to equal 2. (Counting the 5 and 4, not the N/A N/A, not the cell above current cell, and not the first cell.)
The number of cells in the column will vary.
I want this for 260 consecutive columns.
Try this:
Sub counter()
Dim col As Integer
Dim lastrow As Integer
Dim cellcount As Integer
With ActiveCell
col = .Column
lastrow = .Row - 2
End With
cellcount = 0
For Each cell In ActiveSheet.Range(Cells(2, col), Cells(lastrow, col))
If IsError(cell) Then GoTo skipcell
If cell.Value > 0 And IsNumeric(cell) Then cellcount = cellcount + 1
skipcell:
Next cell
ActiveCell = cellcount
End Sub
It takes the active cell and finds the selected colum and find the cell two above the active cell.
It then loops though the range adding to a counter each time it finds a value higher than "0"
As requested by OP in comments added in checks to ensure date in the cell is Numeric and that there is not a error (#N/A) value in the cell
Also requested is for this to span 260 columns in the same row. For this, use of a for loop is employed:
Sub counter()
Dim firstCol as Integer
dim lastCol as Integer
firstCol = 1 'You can change this value depending on your first column
' for example you might use ActiveCell.Column
lastCol = firstCol + 260
Dim col As Integer
Dim lastrow As Integer
lastRow = 6 ' Make this the actual last row of the data to include
Dim cellcount As Integer
for col = firstCol to lastCol
cellcount = 0
For Each cell In ActiveSheet.Range(Cells(2, col), Cells(lastrow, col))
If IsError(cell) Then GoTo skipcell
If cell.Value > 0 And IsNumeric(cell) Then cellcount = cellcount + 1
skipcell:
Next cell
ActiveSheet.Cells(lastRow + 2, col) = cellcount
Next col
End Sub
Why does this have to be VBA code?
It is very simple to do in a cell formula:
=COUNTIF(A1:A5,"<>0")-2
This counts all the cells in the given range (A1:A5) which are not equal to zero. Since you know you want to remove the header row and one row above, subtract 2 from the answer. Of course, this the same as
=COUNTIF(A2:A4,"<>0")
If you want to use this in VBA then look into WorksheetFunction:
Dim myCount As Integer
myCount = WorksheetFunction.COUNTIF(ActiveSheet.Range("A2:A4"),"<>0")
Then insert myCount into the sheet
ActiveSheet.Range("A6").value = myCount
How can I create a macro that will add a day in one cell and subtract a day in another cell at the same time? Here is what I have so far.
Sub ChangeDates()
Dim cell As Range
For Each cell In Range("B:B")
cell.Value = cell.Value + 1
Next cell
For Each cell In Range("C:C")
cell.Value = cell.Value - 1
End Sub
I know you've accepted an answer, but I would like to offer this approach, which is even faster and more efficient than looping through all those cells.
If your dates are in Column A, then Column B will hold date +1 and Column C will hold date -1
Option Explicit
Sub ChangeDates()
Dim myRange As range
Dim mySheet As Worksheet
Set mySheet = Sheets("Sheet7") 'change to your sheet
With mySheet
Set myRange = .range("A1:A" & .range("A" & .Rows.Count).End(xlUp).Row)
myRange.Offset(, 1).FormulaR1C1 = "=RC[-1]+1"
myRange.Offset(, 2).FormulaR1C1 = "=RC[-2]-1"
End With
End Sub
Offset to the rescue!!
Sub ChangeDates()
Dim cell As Range
For Each cell In Range("B:B")
cell.Value = cell.Value + 1
cell.offset(0,1).value = cell.offset(0,1).value - 1
Next cell
End Sub
Another thing you may consider is either looking at usedrange to not have to iterate through all of column B or put in a check to make sure the cells aren't blank... Just faster, better coding and stops you from having bad values where the cells were originally blank...
Sub ChangeDates()
Dim cell As Range
For Each cell In Intersect(Range("B:B"), ActiveSheet.UsedRange)
cell.Value = cell.Value + 1
cell.Offset(0, 1).Value = cell.Offset(0, 1).Value - 1
Next cell
End Sub