I have a huge spreadsheet. I want to loop through all cells and change the white fill to no fill. This code either takes too long or crashes my computer so I cannot tell if it actually works. Does anyone see anything wrong with it?
Sub Remove_White_Cells()
Application.ScreenUpdating = False
Dim cell As Range
Dim wb As Workbook
Dim ws As Worksheet
For Each ws In ActiveWorkbook
For Each cell In Worksheets
If cell.Interior.Color = RGB(0, 0, 0) Then
cell.Interior.Color = xlNone
End If
Next cell
Next ws
End Sub
First of all, code that loops through every cell in every worksheet is extremely inefficient. For this reason I would use .UsedRange to limit it to the used cells.
The result is the following:
Sub Remove_White_Cells()
Application.ScreenUpdating = False
Dim cell As Range
Dim wb As Workbook
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets 'Worksheet iterator
For Each cell In ws.UsedRange.Cells 'Select only used cells
If cell.Interior.Color = RGB(0, 0, 0) Then
cell.Interior.Color = xlNone
End If
Next cell
Next ws
Application.ScreenUpdating = True
End Sub
Related
I would like to color rows with specific cell values (string) in a data set.
I have come across the following code which works perfectly with "entire row" but I would like to color the row only up to the last column which contains some value (and there are spaces in between).
I have tried to specify the last column and use it with Range to color, but it does not go well with vCell...
Thank you for the help!
Sub Highlight()
Dim vCell As Range
'Loop through every used cell in the active worksheet
For Each vCell In ActiveSheet.UsedRange
If InStr(vCell.Value, "anyword") Then
vCell.Font.Color = RGB(0, 0, 0)
vCell.EntireRow.Interior.Color = RGB(204, 255, 204)
End If
Next
End Sub
Try below modified sub.
Sub Highlight()
Dim vCell As Range
Dim lastCol As Long
'Loop through every used cell in the active worksheet
For Each vCell In ActiveSheet.UsedRange
If InStr(vCell.Value, "anyword") Then
vCell.Font.Color = RGB(0, 0, 0)
lastCol = Cells(vCell.Row, Columns.Count).End(xlToLeft).Column
Range(Cells(vCell.Row, vCell.Column), Cells(vCell.Row, lastCol)).Interior.Color = RGB(204, 255, 204)
End If
Next
End Sub
Is this what you are trying?
Option Explicit
Sub Highlight()
Dim vCell As Range
Dim lCol As Long
Dim ws As Worksheet
'~~> Set this to the relevant worksheet
Set ws = Sheet1
With ws
'~~> Loop through every used cell in the active worksheet
For Each vCell In .UsedRange
If InStr(vCell.Value, "anyword") Then
vCell.Font.Color = RGB(0, 0, 0)
'~~> Find last column in that row
lCol = .Cells(vCell.Row, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(vCell.Row, 1), .Cells(vCell.Row, lCol)).Interior.Color = RGB(204, 255, 204)
End If
Next
End With
End Sub
I have written a short Macro to change cells of a given colour to another colour in a workbook. This code throws no errors however it simply does nothing.
I have already tested the colour codes to see if they are correct using MsgBox ActiveCell.DisplayFormat.Interior.color
Option Explicit
Sub Recolour()
Application.ScreenUpdating = False
Dim Sheet As Worksheet
Dim Rng As Range
Dim OldColour As Variant
Dim NewColour As Variant
Dim Cell As Range
Set Rng = ActiveSheet.Range("A1:Y457")
OldColour = 128
NewColour = RGB(134, 38, 51)
For Each Sheet In ThisWorkbook.Worksheets
For Each Cell In Rng.Cells
If ActiveCell.DisplayFormat.Interior.Color = OldColour _
Then _
Set ActiveCell.DisplayFormat.Interior.Color = NewColour _
Else
Next Cell
Next Sheet
Application.ScreenUpdating = True
End Sub
This is probably something simple and daft however I need to ask.
DisplayFormat is read-only. If you want to change the property, you need to drop DisplayFormat. Also, if you are using For each Cell, then you should refer to Cell, not ActiveCell.
For Each Sheet In ThisWorkbook.Worksheets
For Each Cell In Rng.Cells
If Cell.Interior.color = OldColour Then
Cell.Interior.color = NewColour
End if
Next Cell
Next Sheet
You only need to Set object variables in VBA, your if statement is also problematic. Try:
For Each Sheet In ThisWorkbook.Worksheets
For Each Cell In Rng.Cells
If ActiveCell.DisplayFormat.Interior.color = OldColour Then
ActiveCell.DisplayFormat.Interior.color = NewColour
End if
Next Cell
Next Sheet
I'm using this code below to convert formula to cells, which works fine in a single sheet. But the problem is when I need to convert all selected cells which are in different sheets to their value, this code doesn't do it.
This is how I am selecting the cells in Excel:
first I select the cells in one sheet, than I go down to the tabs right-click and select specific sheets, which in Excel selects the corresponding cells in every selected sheet.
So any tips on how I can change this code to make it work across different sheets?
Sub formulaToValues()
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each cel In Selection.Cells
cel.Value = cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
End If
End Sub
You should be able to just grab the address of the selection, then add that to each worksheet's range
Sub formulaToValues()
Dim celAddr As String
celAddr = Selection.Address
Dim ws As Worksheet
For Each ws In ActiveWindow.SelectedSheets
With ws.Range(celAddr)
.Value = .Value
.Interior.ColorIndex = 0
.Font.Color = vbBlack
End With
Next ws
End Sub
You are attempting to write to a 3D cell collection. An interesting problem i haven't seen before. I gave it a shot.
The below code works for me. I have simply added an extra loop to search through any other sheets. Note: it is good practice to always declare your variables.
Answer1: This cycles through every sheet in the workbook
Sub formulaToValues()
Dim cel As Range
Dim ws As Worksheet
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each ws In ThisWorkbook.Worksheets
For Each cel In Selection.Cells
ws.Range(cel.Address).Value = 2 'cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
Next ws
End If
End Sub
Answer2: With this one it only goes throug the selected sheets
Sub formulaToValues()
Dim cel As Range
Dim ws As Worksheet
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each ws In ThisWorkbook.Windows(1).SelectedSheets
For Each cel In Selection.Cells
ws.Range(cel.Address).Value = 2 'cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
Next ws
End If
End Sub
Thanks alot guys, this got answered pretty quickly.
I am placing my macros in personal so I ended if with this
Sub formulaToValues3()
Dim cel As Range
Dim ws As Worksheet
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each ws In ActiveWorkbook.Windows(1).SelectedSheets
For Each cel In Selection.Cells
ws.Range(cel.Address).Value = ws.Range(cel.Address).Value 'cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
Next ws
End If
End Sub
I am trying to write a simple thing that will merge cells in excel with the same information. What I've got thus far is what follows:
Private Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("B2:B1000") 'Set the range limits here
Set rngMerge2 = Range("C2:C1000")
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = False
Application.ScreenUpdating = True
For Each cell In rngMerge2
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub
So the problem I'm encountering is split into two issues, First I'm trying to get this to work for columns A - AK but as you can see above I don't know how to combine it without just making it repeat the same thing 30 times over. Is there another way to group it.
Also when I assign the range to Range("AF2:AF1000") and Range("AG2:AG1000") then excel in its entirety crashes. I was hoping you all could help steer me into the right direction.
Repeat code inside a subroutine is a sign that some of the routines functionality should be extracted into its own method.
Performance
1000 seems like an arbitrary row: Range("B2:B1000"). This range should be trimmed to fit the data.
It is better to Union all the cells to be merged and merge them in a single operation.
Application.DisplayAlerts does not need to be set to True. It will reset after the subroutine has ended.
Public Sub MergeCells()
Dim Column As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1")
For Each Column In .Columns("A:K")
Set Column = Intersect(.UsedRange, Column)
If Not Column Is Nothing Then MergeEqualValueCellsInColumn Column
Next
End With
Application.ScreenUpdating = True
End Sub
Sub MergeEqualValueCellsInColumn(Target As Range)
Application.DisplayAlerts = False
Dim cell As Range, rMerge As Range
For Each cell In Target
If cell.Value <> "" Then
If rMerge Is Nothing Then
Set rMerge = cell
Else
If rMerge.Cells(1).Value = cell.Value Then
Set rMerge = Union(cell, rMerge)
Else
rMerge.Merge
Set rMerge = cell
End If
End If
End If
Next
If Not rMerge Is Nothing Then rMerge.Merge
End Sub
You keep modifying the cells in rngMerge but not the definition of it before reusing it. This would likely work better if you started at the bottom and worked up as the situation is similar to inserting or deleting rows.
Option Explicit
Private Sub MergeCells()
Dim i As Long, c As Long, col As Variant
Application.DisplayAlerts = False
'Application.ScreenUpdating = false
col = Array("B", "C", "AF", "AG")
For c = LBound(col) To UBound(col)
For i = Cells(Rows.Count, col(c)).End(xlUp).Row - 1 To 2 Step -1
If Cells(i, col(c)).Value = Cells(i, col(c)).Offset(1, 0).Value And Not IsEmpty(Cells(i, col(c))) Then
Cells(i, col(c)).Resize(2, 1).Merge
Cells(i, col(c)).HorizontalAlignment = xlCenter
Cells(i, col(c)).VerticalAlignment = xlCenter
End If
Next i
Next c
Application.DisplayAlerts = True
'Application.ScreenUpdating = True
End Sub
I've added a wrapping loop that cycles through multiple columns pulled from an array.
I've also notice the Private nature of the sub procedure and I'm guess that this is in a worksheet's private code sheet (right-click name tab, View Code). If the code is to be run on multiple worksheets, it belongs in a public module code sheet (in the VBE use Insert, Module) and proper parent worksheet references should be added to the Cells.
It appears you are running the same procedure on rngMerge and rngMerge2, and that they are the same size.
I suggest the following, where you just iterate through the columns, and then through the cells in each column:
Option Explicit
Private Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Dim rngFull As Range
Set rngFull = Range("B2:AK1000")
For Each rngMerge In rngFull.Columns
For Each cell In rngMerge.Cells
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
'Add formatting statements as desired
End If
Next cell
Next rngMerge
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub
NOTE As written, this will only handle duplicates. If you have triplets or more, only pairs of two will be combined.
I would frame the problem a bit differently. Your code goes through each cell in the range, compares it to the next cell, and, if the values of the two are equivalent, then merge them together. I think it a bit clearer to check each cell against the previous cell value instead.
Also, you can iterate over the columns in order to avoid code repetition (as mentioned in other answers).
Sub MergeCells()
Dim wks As Worksheet
Dim mergeRange As Range
Dim column As Range
Dim cell As Range
Dim previousCell As Range
'Because the Sheets property can return something other than a single worksheet, we're storing the result in a variable typed as Worksheet
Set wks = Sheets("Sheet1")
'To run this code across the entire "used part" of the worksheet, use this:
Set mergeRange = wks.UsedRange
'If you want to specify a range, you can do this:
'Set mergeRange = wks.Range("A2:AK1000")
For Each column In mergeRange.Columns
For Each cell In column.Cells
If cell.Row > 1 Then
'cell.Offset(-1) will return the previous cell, even if that cell is part of a set of merged cells
'In that case, the following will return the first cell in the merge area
Set previousCell = cell.Offset(-1).MergeArea(1)
If cell.Value = previousCell.Value And Not IsEmpty(cell) Then
cell.Value = ""
wks.Range(previousCell, cell).Merge
End If
End If
Next
Next
End Sub
If you want to run this code on multiple ranges, you can isolate the code which carries out the merges within a range, into its own Sub procedure:
Sub MergeCellsInRange(mergeRange As Range)
For Each column In mergeRange.Columns
For Each cell In column.Cells
If cell.Row > 1 Then
Set previousCell = cell.Offset(-1).MergeArea(1)
If cell.Value = previousCell.Value And Not IsEmpty(cell) Then
cell.Value = ""
wks.Range(previousCell, cell).Merge
End If
End If
Next
Next
End Sub
and call it multiple times from your main procedure:
Sub MergeCells()
Dim wks As Worksheet
Dim mergeRange As Range
Dim column As Range
Dim cell As Range
Dim previousCell As Range
Set wks = Sheets("Sheet1")
MergeRange wks.Range("A2:U1000")
MergeRange wks.Range("AA2:AK1000")
End Sub
References:
Excel object model
Global Sheets property, Sheets collection
Worksheet object
UsedRange property
Range object
Cells property
Row property
Offset property
MergeArea property
Value property
VBA
For Each ... In construct
IsEmpty function
Dim statement
Set statement
Sub statement
I have a macro with a loop logic that I copied off of another stackoverflow/ms support page, but it doesn't seem to work.
I am not experienced with VBA so I am having trouble figuring out why the 'loop through all worksheets' part isn't working.
Can anyone please take a look at my code and tell me how it can be fixed?
Sub HideEmptyRows()
Dim rngName As Range
Dim cell As Range
Dim ws_count As Integer
Dim i As Integer
ws_count = ActiveWorkbook.Worksheets.Count
For i = 1 To ws_count
Application.ScreenUpdating = False
For Each Current In Worksheets
' This code hides the adv and group merch rows
For Each cell In Range("eq29", "eq51")
If cell.Value = 0 Then
cell.EntireRow.Hidden = True
Else
cell.EntireRow.Hidden = False
End If
Next cell
' This code hides the consulting rows
For Each cell In Range("eq61", "eq172")
If cell.Value = 0 Then
cell.EntireRow.Hidden = True
Else
cell.EntireRow.Hidden = False
End If
Next cell
Next
Application.ScreenUpdating = True
Next i
End Sub
As per my comment:
You have not assigned any of the range objects to a parent sheet so it only works on the active sheet. Just because you are looping does not automatically assign the sheet to those ranges. You will need to put Current. in front of ALL Range Objects.
The outer loop was not necessary.
I redid the logic on the hide to save some typing:
Sub HideEmptyRows()
Dim rngName As Range
Dim cell As Range
Dim current As Worksheet
Application.ScreenUpdating = False
For Each current In Worksheets
' This code hides the adv and group merch rows
For Each cell In current.Range("EQ29:EQ51")
cell.EntireRow.Hidden = cell.Value = 0
Next cell
' This code hides the consulting rows
For Each cell In current.Range("EQ61:EQ172")
cell.EntireRow.Hidden = cell.Value = 0
Next cell
Next
Application.ScreenUpdating = True
End Sub