I have a big table (100 columns * 1000 rows) and certain cells in this table are filled with different colors (red, yellow, blue, orange and other colors). I want to clear all selected cells that have no colors. I wrote a simple macro that will be good for a small table, but for a large table, the computational power drops and if several colored cells are selected in the same range, then the cells are not cleared. How can I reduce the cleaning time of the table and fix the error when the specified area has different colors?
Sub ClearData()
For Each cell in Selection
If cell.Interior.ColorIndex = xlNone Then
cell.ClearContents
End If
Next cell
MsgBox "Done!"
End Subs
Sub ClearData()
Dim Cell As Range
Dim URng As Range
For Each Cell In Selection
If Cell.Interior.ColorIndex = xlNone Then GoSub UnionRange
Next
If Not URng Is Nothing Then URng.ClearContents: MsgBox "Done!"
Exit Sub
UnionRange:
If Not URng Is Nothing Then
Set URng = Union(URng, Cell)
Else
Set URng = Cell
End If
Return
End Sub
Try this code
Sub ClearData()
Dim c As Range, r As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1")
For Each c In .Range("A1").CurrentRegion
If c.Interior.ColorIndex = xlNone Then
If r Is Nothing Then Set r = c Else Set r = Union(r, c)
End If
Next c
If Not r Is Nothing Then r.Cells.Clear
End With
Application.ScreenUpdating = True
MsgBox "Done...", 64
End Sub
Related
I am trying to write a code for Excel in VBA which looks at a range of cells, in this example Range B4:B15, and first identifies which cells have a yellow fill color (interior color). Then of the cells colored yellow determine if any of those cells are blank.
If any of the yellow cells are blank, give a message for the entire range saying "there are yellow cells that are blank".
I'm using a For each rcell in r loop to determine which cells are yellow colored.
How do I build a new "sub-range" with only the cells colored yellow?
Sub Input_Checker_test()
Dim ws As Worksheet
Set ws = Sheets("Main")
Dim r As Range
Dim rcell As Range
Dim rmain As Range
Dim rmaincell As Range
Set r = Range("B4:B15").Cells
For Each rcell In r
If rcell.Interior.Color = 65535 Then
rcell = rmain
End If
Next rcell
For Each rmaincell In rmain
If WorksheetFunction.CountA(rmain) = 0 Then
MsgBox ("Cells are empty")
Else
MsgBox ("Cells are full")
End If
Next rmaincell
End Sub
I'm a little confused because you said font, then interior. If there is a yellow font, then there has to be a value, so I assumed you meant interior. Since you only need one of each to meet your criteria, you don't need to create a sub-range. You can test to see if any cells meet both criteria.
Sub Input_Checker_test()
Dim ws As Worksheet
Set ws = Sheets("Main")
Dim r As Range
Dim rcell As Range
Dim YellowCount as Integer
Dim EmptyCount as Integer
Set r = ws.Range("B4:B15")
For Each rcell In r
If rcell.Interior.Color = 65535 Then
YellowCount = 1
If IsEmpty(rcell) Then
EmptyCount = 1
End If
End If
Next rcell
If YellowCount > 0 Then
MsgBox "There are yellow cells"
End If
If EmptyCount > 0 Then
MsgBox "There are empty cells"
End If
End Sub
I found a procedure to highlight merged cells in an active sheet:
I tried a ActiveCell.EntireRow.Delete statement to delete the row that is currently iterated over.
Sub DeleteRows()
Dim x As Range
For Each x In ActiveSheet.UsedRange
If x.MergeCells Then
x.Interior.ColorIndex = 8
ActiveCell.EntireRow.Delete
End If
Next
End Sub
I don't care about highlighting the merged cells. The goal is to delete any row that has a merged cell.
Find out all merged cell ranges, club them and delete in one go.
Sub DeleteRows()
Dim x As Range
Dim rngDelete As Range
For Each x In ActiveSheet.UsedRange
If x.MergeCells Then
If rngDelete Is Nothing Then
Set rngDelete = x
Else
Set rngDelete = Union(rngDelete, x)
End If
End If
Next
If Not rngDelete Is Nothing Then
rngDelete.EntireRow.Delete
End If
End Sub
When deleting rows, always delete from the bottom up or a) you risk deleting the next cell you want to examine and b) you risk skipping over a row that comes up to take the place of a deleted row.
Sub DeleteRows()
Dim r as long, c as long
with ActiveSheet.UsedRange
'work backwards through the rows
For r = .rows.count to 1 step -1
'work forwards through the columns
For c = 1 to .columns.count
If .cells(r, c).MergeCells Then
'once a merged cell is found, delete then go immediately to the next row
.cells(r, c).EntireRow.Delete
exit for
End If
next c
Next r
end with
End Sub
A quick way to do this is to find all the merged cells then delete them in one go: a good way to do this is to use a range.find using a cells 'format' as merged then combine the found ranges
The following code loops through merged ranges and creates a union then selects the entire rows
Sub SelectMerge()
Dim rng As Range, rngUnion As Range, Test As Range
Dim ws As Worksheet: Set ws = ActiveSheet
With Application.FindFormat
.Clear
.MergeCells = True
End With
With ws.UsedRange
Set rng = .Find("", SearchFormat:=True)
Do
If Not rngUnion Is Nothing Then Set rngUnion = Application.Union(rng, rngUnion)
If rngUnion Is Nothing Then Set rngUnion = rng
If rng Is Nothing Then Exit Do
Set rng = .Find("", After:=rng, SearchFormat:=True)
Loop While Application.Intersect(rng, rngUnion) Is Nothing
End With
If Not rngUnion Is Nothing Then rngUnion.EntireRow.Select 'rngUnion.EntireRow.Delete
End Sub
I have a button that will hide rows within a range if the cell has a specific color, I need it to toggle though back and forth hiding/unhiding the rows with each click. I don't know enough about VBA to fix it.
Sub hide_green()
Dim Rng As Range
Dim MyCell As Range
Set Rng = Range("A11:A100")
For Each MyCell In Rng
If MyCell.Interior.ColorIndex = 43 Then
MyCell.EntireRow.Hidden = True
End If
Next MyCell
End Sub
Also is it possible to change the text of the button each click to coordinate with "Hide" "Unhide"?
Just add a second if to see if it's currently hidden or not.
Sub hide_green()
Dim Rng As Range
Dim MyCell As Range
Set Rng = Range("A11:A100")
For Each MyCell In Rng
If MyCell.Interior.ColorIndex = 43 Then
If MyCell.EntireRow.Hidden = True Then
MyCell.EntireRow.Hidden = False
Else
MyCell.EntireRow.Hidden = True
End If
End If
Next MyCell
End Sub
Liss has a good build on your code, though I would replace the If statements with a Select Case, just so it's cleaner.
For Each MyCell In Rng
If MyCell.EntireRow.Hidden=True Then
MyCell.EntireRow.Hidden=False
Else
Select Case MyCell.Interior.ColorIndex
Case = 43
MyCell.EntireRow.Hidden = True
Case <> 43
MyCell.EntireRow.Hidden = False
End Select
End If
Next MyCell
Use this to quickly mark what color the rows are (on another column)
Then just do filtering as usual
My code currently colors values in Range("N2:N86") anytime I insert a value in that range. However, I want to add an additional line of code that colors or highlights the preceding column Range("M2:M86") whenever a value is entered in Range("N2:N86").
So for example, if i put the value of 1 in N2, I want both N2 and M2 to be highlighted red. Thanks
Dim rCell As Range
Dim inRng As Range
Dim rRng As Range
Set myRng = Range("N2:N86")
myRng.Locked = True
If Range("R4") < 0 Then
For Each rCell In myRng
If rCell.Value > 0 Then
If rRng Is Nothing Then
Set rRng = rCell
Else
Set rRng = Application.Union(rRng, rCell)
End If
End If
Next
rRng.Locked = False
rRng.Interior.ColorIndex = 3
End If
I'm not 100% sure on what you are asking for, but here's something that you can test. (Colors rows in both columns upon change in cell value in N column)
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Range("N2:N86"), Target) Is Nothing Then
Target.Interior.ColorIndex = 36
Target.Offset(, -1).Interior.ColorIndex = 36
End If
Application.EnableEvents = True
End Sub
i have the following code which would auto-fill the date in column B once i add value's in column A.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
If r.Offset(0, 1).Value = "" Then
r.Offset(0, 1).Value = Date & " " & Time = "hh:mm:ss AM/PM"
End If
Next r
Application.EnableEvents = True
End Sub
what im looking for is to also add the current time to column C.
ok so i found what im looking for but it requires little modification where the date and time are being set.
below is the code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("D:D")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
If r.Value > 0 Then
r.Offset(0, -3).Value = Date
r.Offset(0, -3).NumberFormat = "dd-mm-yyyy"
r.Offset(0, -2).Value = Time
r.Offset(0, -2).NumberFormat = "hh:mm:ss AM/PM"
Else
r.Offset(0, -3).Value = ""
r.Offset(0, -2).Value = ""
End If
Next r
Application.EnableEvents = True
End Sub
to auto-fill column E with date, instead of column A
and auto-fill column F with time, instead of column B
and if possible im trying to have the same process but another cell on the same sheet.
While you might look at using SpecialCells to do this in one hit rather than a loop, a simple mod to your code would be:
one-shot per range area method
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
On Error Resume Next
For Each r In Inte.Areas
r.Offset(0, 1).Cells.SpecialCells(xlCellTypeBlanks) = Date
r.Offset(0, 2).Cells.SpecialCells(xlCellTypeBlanks) = Time
Next r
Application.EnableEvents = True
End Sub
initial answer
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
If r.Offset(0, 1).Value = vbNullString Then r.Offset(0, 1).Value = Date
If r.Offset(0, 2).Value = vbNullString Then r.Offset(0, 2).Value = Time
Next r
Application.EnableEvents = True
End Sub
if you want to:
put current Date in Target adjacent column blank cells
put current Time in Target adjacent column blank cells adjacent cells
then go like follows:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Range("A:A"), Target).Address <> Target.Address Then Exit Sub '<--| exit if all target cells aren't in column "A"
Application.EnableEvents = False
If WorksheetFunction.CountBlank(Target.Offset(, 1)) = 0 Then Exit Sub '<--| exit if no blank cells in target adjacent column
With Target.Offset(, 1).SpecialCells(xlCellTypeBlanks) '<--| reference blank cells in target adjacent column
.Value = Date '<--| set referenced cells value to the current date
.Offset(, 1).Value = Time '<--| set referenced cells adjacent ones value to the current time
End With
Application.EnableEvents = True
End Sub
While if you want to:
put current Date in Target adjacent column blank cells
put current Time in Target two columns offset blank cells
then go like follows:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Range("A:A"), Target).Address <> Target.Address Then Exit Sub '<--| exit if all target cells aren't in column "A"
Application.EnableEvents = False
On Error Resume Next
Target.Offset(, 1).SpecialCells(xlCellTypeBlanks).Value = Date '<--| set target adjacent column blank cells to the current date
Target.Offset(, 2).SpecialCells(xlCellTypeBlanks).Value = Time '<--| set target two columns offset blank cells to the current time
Application.EnableEvents = True
End Sub
where the On Error Resume Next is there to avoid two distinct If WorksheetFunction.CountBlank(someRange) Then someRange.SpecialCells(xlCellTypeBlanks).Value = someValue statements
Normally you would avoid On Error Resume Next statement and ensure you're handling any possible errors.
But in this case, being it confined to the last two statements of a sub, I think it's a good trade off in favour of code readability without actually loosing its control