I'm new to VBA and English isn't my native language so here goes.
I want to conditional format rows/ range (giving them green-colored background) if cell C in that row have duplicate value in column C and also if there's a cell in column O that equals 0, but if the cell in column C has no similar value, don't apply the conditional format to that cell (eventhough cells in column O has the value of 0).
Note: Cells that have same values in column C will always be above and below each other, for example it's possible that C1=C2=C3 but not C1<>C2, C1=C3
I know I'm not explaining it clearly, so please just let me know if you want more information.
Update (more information): I may have 3 or more rows with same C column value above and below each other, and the zero value in column O will always be the bottom row.
Example:
If C1=C2=C3=C4=C5 and O5=0 , Rows 1 2 3 4 5 become green colored.
I prefer using conditional format even if it needs vba code so I dont have to run it everytime there's new 0 in column O.
I've used this code but it doesn't work (obviously), but maybe it's a little different with my question because the real data is more complicated than what I illustrated. My data table starts at 4th row (header on 3rd). This code only formats 1 row (above the row that has zero column O value) and what I need is all rows with same column C value are formatted. Please keep in mind that I'm a newbie in vba :(
With Range("A4:r8000").FormatConditions.Add( _
Type:=xlExpression, _
Formula1:="=AND($C4=$C5,$O5=0,$F4<>0)")
.Interior.Color = 13551615
.Font.Color = -16383844
End With
Try this as the formula for the CFR,
=and(countif(c:c, c1)>1, o1=0, len(o1))
'alternate for part that I am not sure I understand
=and(countif(c$1:c1, c1)>1, o1=0, len(o1))
This will go through and highlight duplicate cells if any of the duplicate cells' rows have '0' in column O. I am still working on a way that will make this auto update whenever a change happens in Column O, but can't quite figure that out. Will update when I do.
Sub ConditionalFormatSE()
Application.ScreenUpdating = False
Dim lastRow As Long
Dim myCell As Range
Dim colCVals As Range
lastRow = Cells(Rows.Count, 3).End(xlUp).Row
Set colCVals = Range("C1", "C" & lastRow)
colCVals.clearformats
For Each myCell In colCVals
If Cells(myCell.Row, 15).Value = "0" Then
If WorksheetFunction.CountIf(colCVals, myCell.Value) > 1 Then
Set c = colCVals.Find(myCell.Value)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Interior.color = RGB(198, 239, 206)
c.Font.color = RGB(0, 97, 0)
Set c = colCVals.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End If
End If
Next myCell
Set colCVals = Nothing
Set myCell = Nothing
Set c = Nothing
Application.ScreenUpdating = True
End Sub
As for making it run automatically, put this in: VBAProject([workbookname].xlsm)->Microsoft Excel Objects->Sheet1([sheetname]) and it should run whenever a value in column 'O' is changed
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Columns(15)
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
Call ConditionalFormatSE
End If
Set KeyCells = Nothing
End Sub
If cells with same values are always grouped (one below the other), following code might do what you want.
Sub Test()
Dim lLastRow As Long
Dim i As Integer
lLastRow = Worksheets("Sheet1").Cells(Rows.Count, 3).End(xlUp).Row
For i = 1 To lLastRow
If ((Worksheets("Sheet1").Cells(i + 1, 3).Value = Worksheets("Sheet1").Cells(i, 3).Value) And (Worksheets("Sheet1").Cells(i, 15).Value = "0")) Then
Worksheets("Sheet1").Cells(i, 3).Interior.Color = vbGreen
End If
Next i
End Sub
Related
I have searched a lot about my question but could not find the answer I need.
I have a table A1:DT97138. Within this table I want to check per row, starting from cell B2 to DT2 if all the cells in one row are empty. Then output "Empty" or "Not Empty" in the next cell, DU2. Then do the same for row 3, 4 etc to 97138 (and output the same results row per row in DU2, DU3 etc).
I found out how to do this for 1 specific row, as you can see below, but I cannot find out how to iterate trough the whole range, row by row.
Sub rowEmpty()
Dim rng As Range, r As Range
Set rng = Range("B2:DT97138")
If WorksheetFunction.CountA(Range("B2:DT2")) = 0 Then
Cells(2, 125) = "Empty"
Else
Cells(2, 125) = "Not Empty"
End If
End Sub
Thanks for your help!
Your are doing well. Just need to loop thru the range like this.
Sub rowEmpty()
Dim rng As Range, r As Range
Set rng = Range("B2:DT97138")
For Each r In rng.Rows
If WorksheetFunction.CountA(r) = 0 Then
Cells(r.Row, 125) = "Empty"
Else
Cells(r.Row, 125) = "Not Empty"
End If
Next r
End Sub
Enter your formula at once in the last column:
With Range("DU2:DU97138")
.Formula = "=IF(COUNTA(B2:DT2)=0,""Empty"",""Not Empty"")"
'then eventually convert it to constants
.Value = .Value
End With
No loops, simpler, probably much faster :-)
I am a new user of VBA and am trying to do the following (I got stuck towards the end):
I need to locate the first empty cell across every row from column C to P (3 to 16), take this value, and paste it in the column B of the same row.
What I try to do was:
Find non-empty cells in column C, copy those values into column B.
Then search for empty cells in column B, and try to copy the first non-empty cell in that row.
The first part worked out fine, but I am not too sure how to copy the first non-empty cell in the same row. I think if this can be done, I might not need the first step. Would appreciate any advice/help on this. There is the code:
Private Sub Test()
For j = 3 To 16
For i = 2 To 186313
If Not IsEmpty(Cells(i, j)) Then
Cells(i, j - 1) = Cells(i, j)
End If
sourceCol = 2
'column b has a value of 2
RowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row
'for every row, find the first blank cell, copy the first not empty value in that row
For currentRow = 1 To RowCount
currentRowValue = Cells(currentRow, sourceCol).Value
If Not IsEmpty(Cells(i, 3)) Or Not IsEmpty(Cells(i, 4)) Or Not IsEmpty(Cells(i, 5)) Or Not IsEmpty(Cells(i, 6)) Then
Paste
~ got stuck here
Next i
Next j
End Sub
Your loop is really inefficient as it is iterating over millions of cells, most of which don't need looked at. (16-3)*(186313-2)=2,422,043.
I also don't recommend using xlUp or xlDown or xlCellTypeLastCell as these don't always return the results you expect as the meta-data for these cells are created when the file is saved, so any changes you make after the file is saved but before it is re-saved can give you the wrong cells. This can make debugging a nightmare. Instead, I recommend using the Find() method to find the last cell. This is fast and reliable.
Here is how I would probably do it. I'm looping over the minimum amount of cells I can here, which will speed things up.
You may also want to disable the screenupdating property of the application to speed things up and make the whole thing appear more seemless.
Lastly, if you're new to VBA it's good to get in the habit of disabling the enableevents property as well so if you currently have, or add in the future, any event listeners you will not trigger the procedures associated with them to run unnecessarily or even undesirably.
Option Explicit
Private Sub Test()
Dim LastUsed As Range
Dim PasteHere As Range
Dim i As Integer
Application.ScreenUpdating=False
Application.EnableEvents=False
With Range("B:B")
Set PasteHere = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
If PasteHere Is Nothing Then Set PasteHere = .Cells(1, 1) Else: Set PasteHere = PasteHere.Offset(1)
End With
For i = 3 To 16
Set LastUsed = Cells(1, i).EntireColumn.Find("*", Cells(1, i), xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
If Not LastUsed Is Nothing Then
LastUsed.Copy Destination:=PasteHere
Set PasteHere = PasteHere.Offset(1)
End If
Set LastUsed = Nothing
Next
Application.ScreenUpdating=True
Application.EnableEvents=True
End Sub
Sub non_empty()
Dim lstrow As Long
Dim i As Long
Dim sht As Worksheet
Set sht = Worksheets("Sheet1")
lstrow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
For i = 1 To lstrow
If IsEmpty(Range("B" & i)) Then
Range("B" & i).Value = Range("B" & i).End(xlToRight).Value
End If
Next i
End Sub
I'm trying to write a macro to change the colors of rows when the values in column B change. Column A will be my controlling column using 1's and 0's, i.e. column A will stay a 1 as long as column B stays the same; whenever B changes, A will flip to a 0, and so on.
I can get it to color the rows correctly when the values in column B change, but the problem arises when I filter the data. For example: let's say I have B2-B4 set to "test1", B5-B7 set to "test2", and B8-B10 set to "test3", then I filter column B to not include "test2". Originally, the rows would be colored differently where the column values changed, but rows B2-B4 and B8-B10 are set to the same color and now they're touching since the "test2" rows are hidden.
Here's the code I used to color the rows, but it doesn't work for filtering:
Sub ColorRows()
Dim This As Long
Dim Previous As Long
Dim LastRow As Long
Dim Color As Integer
Dim R As Long
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
RwColor = Array(15,0)
Color = 0
For R = 2 To LastRow
This = Cells(R, 1).Value
Previous = Cells(R - 1, 1).Value
If This <> Previous Then Color = 1 - Color
Range("A" & R & ":M" & R).Select
Selection.Interior.ColorIndex = RwColor(Color)
Next R
End Sub
How can I fix it so that even after filtering the rows are colored correctly when there is a change in column values?
Here's a way to do this:
1.) Insert the code below as a UDF in a code module.
2.) Then put the formula in A, as A2: =analyseVisible(B2).
This will compare B-cells to the next visible cell above and result in a 'rank'-counter in A.
Now that the counter in A in contiunous (even if rows are hidden), you can use MOD 2 to color it with conditional formatting:
3.) Add a conditional format (from A2 for the whole table): =MOD($A2,2)=1 and set the fill color.
If you use the filter now or change values in B, the rows are re-colored in realtime.
Public Function analyseVisible(r As Range) As Integer
Dim i As Long
If Application.Caller.Row <= 2 Or _
r.Row <> Application.Caller.Row Then
analyseVisible = 1
Exit Function
End If
i = r.Row - 1
While r.Worksheet.Rows(i).Hidden And i > 1
i = i - 1
Wend
If i = 1 Then
analyseVisible = 1
Else
analyseVisible = r.Worksheet.Cells(i, Application.Caller.Column).Value
If r.Worksheet.Cells(i, r.Column).Value <> _
r.Value Then analyseVisible = analyseVisible + 1
End If
End Function
The code below handles the issue by checking only the used & visible rows. It works pretty well, but I was unable to figure out how to fire it when the filter changes. It also does it's comparisons directly on the values that are changing.
Private Sub colorRows()
Dim this As Variant
Dim previous As Variant
Dim currentColor As Long
Dim rng As Range 'visible range
Dim c As Range ' cell
' pick a color to start with
currentColor = vbYellow
' rng = used and visible cells
Set rng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible)
For Each c In rng ' For each cell that is visible and used
If Not c.Row = 1 Then ' skip header row
this = c.Value
'some simple test logic to switch colors
If this <> previous Then
If currentColor = vbBlue Then
currentColor = vbYellow
ElseIf currentColor = vbYellow Then
currentColor = vbBlue
End If
End If
'set interior color
c.Interior.color = currentColor
previous = this
End If
Next c
End Sub
Then, in the module of the worksheet that you want to colorize, call the sub from the Worksheet_Activate() event. (In reality, you probably want a different event. I mostly work with Access, so I don't really know what's available to you. I'm just trying to point you in the right direction to what I'm sure is your next question if you stick with the method you started with.)
Private Sub Worksheet_Activate()
colorRows
End Sub
I am using Excel 2010 and trying to add a bunch of rows placing the sum of columns A and B in column C. If the sum is over 500 I would then like to boldface the number in column C. My code below works works mathematically but will not do the bold formatting. Can someone tell me what I am doing wrong? Thank you.
Public Sub addMyRows()
Dim row As Integer 'creates a variable called 'row'
row = 2 'sets row to 2 b/c first row is a title
Do
Cells(row, 3).Formula = "=A" & row & "+B" & row 'the 3 stands for column C.
If ActiveCell.Value > 500 Then Selection.Font.Bold = True
row = row + 1
'loops until it encounters an empty row
Loop Until Len(Cells(row, 1)) = 0
End Sub
Pure VBA approach:
Public Sub AddMyRows()
Dim LRow As Long
Dim Rng As Range, Cell As Range
LRow = Range("A" & Rows.Count).End(xlUp).Row
Set Rng = Range("C2:C" & LRow)
Rng.Formula = "=A2+B2"
For Each Cell In Rng
Cell.Font.Bold = (Cell.Value > 500)
Next Cell
End Sub
Screenshot:
An alternative is conditional formatting.
Hope this helps.
Note: The formula in the block has been edited to reflect #simoco's comment regarding a re-run of the code. This makes the code safer for the times when you need to re-run it. :)
I've got some code working to condense multiple columns in excel, removing any blank cells and shunting the data upwards.
Every cell contains formulae, I did find a code snippet that let me use a specialcells command, but that only removed truly blank cells and not ones that contained a formula, where the outcome would make the cell blank.
This is what I'm currently using, which was an edit of something I found on this site a while ago:
Sub condensey()
Dim c As Range
Dim SrchRng
Set SrchRng = ActiveSheet.Range("B2", ActiveSheet.Range("B208").End(xlUp))
Do
Set c = SrchRng.Find("", LookIn:=xlValues)
If Not c Is Nothing Then c.Delete
Loop While Not c Is Nothing
End Sub
I tried increasing the range on the active sheet to include a second column, but excel just goes nuts, assuming it's trying to do it for every cell in the entire table.
I've then repeated this piece of code for each column that I want to condense.
Now this is great, it does exactly what I want to do, but it is slow as anything, especially when each column can contain up to 200+ rows. Any ideas on how to improve the performance of this, or maybe re-write it using a different method?
This ran in <1sec on 300rows x 3cols
Sub DeleteIfEmpty(rng As Range)
Dim c As Range, del As Range
For Each c In rng.Cells
If Len(c.Value) = 0 Then
If del Is Nothing Then
Set del = c
Else
Set del = Application.Union(del, c)
End If
End If
Next c
If Not del Is Nothing Then del.Delete
End Sub
I found that using AutoFilter on each column was faster than looping through each cell in the range or "Find"ing each blank cell in the range. Using the code below and some sample data (3 columns with approximately 300 rows of blank and non blank cells), on my machine it took 0.00063657 days. Using the loop through each cell method, it took 0.00092593 days. I also ran your code on the sample data, and it took a lot longer (I didn't let it finish). So far, the method below yields the quickest results, though I imagine someone will find a faster method.
It appears that the delete method is the biggest bottleneck. It may be fastest to filter the non-blank cells and paste them into a new range, and then delete the old range once you're finished.
Sub condensey2()
Dim c As Range
Dim tbl As Range, tblWithHeader As Range, tblEnd As Range, delRng As Range
Dim i As Long
Dim maxRows As Long
Dim t As Double
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ActiveSheet.Calculate
maxRows = ActiveSheet.Rows.Count
ActiveSheet.AutoFilterMode = False
With ActiveSheet
Set tblEnd = Range(.Cells(maxRows, 1), .Cells(maxRows, 3)).End(xlUp)
Set tbl = Range(.Cells(2, 1), Cells(tblEnd.Row, 3))
End With
t = Now()
Set tblWithHeader = tbl.Offset(-1).Resize(tbl.Rows.Count + 1)
i = 1
For i = 1 To tbl.Columns.Count
With tblWithHeader
.AutoFilter
.AutoFilter field:=i, Criteria1:="="
End With
Set delRng = tbl.Columns(i).Cells.SpecialCells(xlCellTypeVisible)
ActiveSheet.AutoFilterMode = False
delRng.Delete xlShiftUp
'redefine the table to make it smaller to make the filtering efficient
With ActiveSheet
Set tblEnd = Range(.Cells(maxRows, 1), .Cells(maxRows, 3)).End(xlUp)
Set tbl = Range(.Cells(2, 1), Cells(tblEnd.Row, 3))
End With
Set tblWithHeader = tbl.Offset(-1).Resize(tbl.Rows.Count + 1)
Next i
t = Now() - t
Debug.Print Format(t, "0.00000000")
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub