I am deleting rows based on the value in column P.
Cells in column P have an if statement: IF(K<10,0,1)
If the value in column P is 0, then the row needs to be deleted.
I am using the following macro which works but takes quite long.
I would like to beable to process about 10000 rows.
It would be much appreciated if I could have some suggestions on speeding up this code.
[I had tried using this if statement: IF(K<10,"",1)
And then deleting rows using SpecialCells(XlCellTypeBlanks) but the the cells are not interpreted as blank , due to the presence of the formula I presume. ]
Sub RemoveBlankRows()
Application.ScreenUpdating = False
'PURPOSE: Deletes any row with 0 cells located inside P
'Reference: www.TheSpreadsheetGuru.com
Dim rng As Range
Dim blankrng As Range
Dim cell As Range
'Store blank cells inside a variable
'On Error GoTo NoBlanksFound
Set rng = Range("P2:P30000") '.SpecialCells(xlCellTypeBlanks)
'On Error GoTo 0
For Each cell In rng
If cell.Value = 0 Then
cell.EntireRow.Delete
'Value = ""
End If
Next
Application.ScreenUpdating = True
End Sub
This looks for 0 and avoids blanks:
Sub RowKiller()
Dim rKill As Range, r As Range, rng As Range
Set rng = Range("P2:P30000")
Set rKill = Nothing
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
For Each r In rng
If r.Value = 0 And r.Value <> "" Then
If rKill Is Nothing Then
Set rKill = r
Else
Set rKill = Union(rKill, r)
End If
End If
Next r
If Not rKill Is Nothing Then rKill.EntireRow.Delete
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
This is only demo code. Tailor it to meet your needs.
Related
I'm trying to update cells that have data validation restrictions on them automatically.
For example - Sheet1 has below column (Column E):
Package Identifier
A
B
C
where the values are taken from the same named column (Column D) in Sheet2.
The below code works for MANUAL changes only
Sheet2 Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim count_cells As Integer
Dim new_value As String
Dim old_value As String
Dim rng As Range
For count_cells = 1 To Range("D1").CurrentRegion.Rows.Count - 1
Set rng = Worksheets("Sheet1").Range("E3:E86")
If Intersect(Target, Range("D" & count_cells + 1)) Is Nothing Then
Else
Application.EnableEvents = False
new_value = Target.Value
Application.Undo
old_value = Target.Value
Target.Value = new_value
rng.Replace What:=old_value, Replacement:=new_value, LookAt:=xlWhole
Target.Select
End If
Next count_cells
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
So, if i manually change value B to Z, all the corresponding values that were B on Sheet1 now change to Z. The problem is, Package Identifier on Sheet2 is dictated by concatenating other columns
=CONCATENATE(B35, "-", "Package", "-", TEXT(C35, "#000"))
This piece of code breaks when trying to use it with the above formula. How can i make this set of code trigger on this formula based output?
Assuming this is how the Validation sheet looks
and this is how the Source sheet looks
Let's say user selects first option in Validation sheet.
Now go back to Source sheet and change 1 to 2 in cell C2.
Notice what happens in Validation sheet
If this is what you are trying then based on the file that you gave, test this code.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aCell As Range
Dim NewSearchValue As String
Dim OldSearchValue As String
Dim NewArrayBC As Variant
Dim OldArrayA As Variant, NewArrayA As Variant
Dim lRow As Long, PrevRow As Long
On Error GoTo Whoa
Application.EnableEvents = False
If Not Intersect(Target, Range("B:C")) Is Nothing Then
lRow = Range("A" & Rows.Count).End(xlUp).Row
'~~> Store new values from Col A, B and C in an array
NewArrayBC = Range("B1:C" & lRow).Value2
NewArrayA = Range("A1:A" & lRow).Value2
Application.Undo
'~~> Get the old values from Col A
OldArrayA = Range("A1:A" & lRow).Value2
'~~> Paste the new values in Col B/C
Range("B1").Resize(UBound(NewArrayBC), 2).Value = NewArrayBC
'~~> Loop through the cells
For Each aCell In Target.Cells
'~~> Check if the prev change didn't happen in same row
If PrevRow <> aCell.Row Then
PrevRow = aCell.Row
NewSearchValue = NewArrayA(aCell.Row, 1)
OldSearchValue = OldArrayA(aCell.Row, 1)
Worksheets("Validation").Columns(2).Replace What:=OldSearchValue, _
Replacement:=NewSearchValue, Lookat:=xlWhole
End If
Next aCell
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
A different approach from Sid's...
Instead of updating values in the DV cells when the source range changes, this replaces the selected value with a link to the matching cell in the DV source range.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngV As Range, rng As Range, c As Range, rngList As Range
Dim f As Range
On Error Resume Next
'any validation on this sheet?
Set rngV = Me.Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo 0
If rngV Is Nothing Then Exit Sub 'no DV cells...
Set rng = Application.Intersect(rngV, Target)
If rng Is Nothing Then Exit Sub 'no DV cells in Target
For Each c In rng.Cells
If c.Validation.Type = xlValidateList Then 'DV list?
Set rngList = Nothing
On Error Resume Next
'see if we can get a source range
Set rngList = Evaluate(c.Validation.Formula1)
On Error GoTo 0
If Not rngList Is Nothing Then
Application.EnableEvents = False
'find cell to link to
Set f = rngList.Find(c.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not f Is Nothing Then
Application.EnableEvents = False
c.Formula = "='" & f.Parent.Name & "'!" & f.Address(0, 0)
Application.EnableEvents = True
End If
Else
Debug.Print "No source range for " & c.Address
End If
End If
Next c
End Sub
I have an Worksheet_Change macro that hides/unhides rows depending on the choice a user makes in a cell with a data validation list.
The code takes a minute to run. It's looping over c.2000 rows. I'd like it to take closer to a few seconds so it becomes a useful user tool.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'Exit the routine early if there is an error
On Error GoTo EExit
'Manage Events
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'Declare Variables
Dim rng_DropDown As Range
Dim rng_HideFormula As Range
Dim rng_Item As Range
'The reference the row hide macro will look for to know to hide the row
Const str_HideRef As String = "Hide"
'Define Variables
'The range that contains the week selector drop down
Set rng_DropDown = Range("rng_WeekSelector")
'The column that contains the formula which indicates if a row should
'be hidden c.2000 rows
Set rng_HideFormula = Range("rng_HideFormula")
'Working Code
'Exit sub early if the Month Selector was not changed
If Not Target.Address = rng_DropDown.Address Then GoTo EExit
'Otherwise unprotect the worksheet
wks_DailyPlanning.Unprotect (str_Password)
'For each cell in the hide formula column
For Each rng_Item In rng_HideFormula
With rng_Item
'If the cell says "hide"
If .Value2 = str_HideRef Then
'Hide the row
.EntireRow.Hidden = True
Else
'Otherwise show the row
.EntireRow.Hidden = False
End If
End With
'Cycle through each cell
Next rng_Item
EExit:
'Reprotect the sheet if the sheet is unprotected
If wks_DailyPlanning.ProtectContents = False Then wks_DailyPlanning.Protect (str_Password)
'Clear Events
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
I have looked at some links provided by other users on this website and I think the trouble lies in the fact I'm having to iterate through each row individually.
Is it possible to create something like an array of .visible settings I can apply to the entire range at once?
I'd suggest copying your data range to a memory-based array and checking that, then using that data to adjust the visibility of each row. It minimizes the number of interactions you have with the worksheet Range object, which takes up lots of time and is a big performance hit for large ranges.
Sub HideHiddenRows()
Dim dataRange As Range
Dim data As Variant
Set dataRange = Sheet1.Range("A13:A2019")
data = dataRange.Value
Dim rowOffset As Long
rowOffset = IIf(LBound(data, 1) = 0, 1, 0)
ApplicationPerformance Flag:=False
Dim i As Long
For i = LBound(data, 1) To UBound(data, 1)
If data(i, 1) = "Hide" Then
dataRange.Rows(i + rowOffset).EntireRow.Hidden = True
Else
dataRange.Rows(i + rowOffset).EntireRow.Hidden = False
End If
Next i
ApplicationPerformance Flag:=True
End Sub
Public Sub ApplicationPerformance(ByVal Flag As Boolean)
Application.ScreenUpdating = Flag
Application.DisplayAlerts = Flag
Application.EnableEvents = Flag
End Sub
Another possibility:
Dim mergedRng As Range
'.......
rng_HideFormula.EntireRow.Hidden = False
For Each rng_Item In rng_HideFormula
If rng_Item.Value2 = str_HideRef Then
If Not mergedRng Is Nothing Then
Set mergedRng = Application.Union(mergedRng, rng_Item)
Else
Set mergedRng = rng_Item
End If
End If
Next rng_Item
If Not mergedRng Is Nothing Then mergedRng.EntireRow.Hidden = True
Set mergedRng = Nothing
'........
to increase perfomance you can populate dictionary with range addresses, and hide or unhide at once, instead of hide/unhide each particular row (but this is just in theory, you should test it by yourself), just an example:
Sub HideHiddenRows()
Dim cl As Range, x As Long
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
x = Cells(Rows.Count, "A").End(xlUp).Row
For Each cl In Range("A1", Cells(x, "A"))
If cl.Value = 0 Then dic.Add cl.Address(0, 0), Nothing
Next cl
Range(Join(dic.keys, ",")).EntireRow.Hidden = False
End Sub
demo:
I'm struggling with the speed at which the following VBA code executes.
The goal of this code is to activate whenever "C4" changes, and then scan column "R" for the value 'Y'. If there's a 'Y', then it hides the row, and if not, it unhides the row. The code works, it's just not speedy - for 500 rows, it can take 30 or more seconds every time I change the value of "C4".
Does anyone have any suggestions to improve the speed at which this code executes? Or another method of accomplishing this?
Thanks for taking a look.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim L As Long
Dim r As Range
L = Cells(Rows.Count, "R").End(xlUp).Row
If Not Intersect(Target, Range("C4")) Is Nothing Then
For Each r In Range("R2:R" & L)
If r.Value = "Y" Then
Rows(r.Row).Hidden = True
Else
Rows(r.Row).Hidden = False
End If
Next
End If
End Sub
In attempting to apply the suggestion below - use Union() - I have come up with the below, not working, code. Any help would be greatly appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim L As Long
Dim r As Range
Dim RowsToHide As Range
Dim RowsToUnhide As Range
L = Cells(Rows.Count, "R").End(xlUp).Row
If Not Intersect(Target, Range("C4")) Is Nothing Then
For Each r In Range("R2:R" & L)
If r.Value = "Y" Then
RowsToHide = Union(RowsToHide, r.Row)
Else
RowsToUnhide = Union(RowsToUnhide, r.Row)
End If
Next
End If
RowsToHide.Hidden = True
RowsToUnhide.Hidden = False
End Sub
Adding Application.EnableEvents = False at the beginning of the code then turning back to true will help, Also using Applciation.ScreenUpdating = False should help as well.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim L As Long
Dim r As Range
Application.EnableEvents = False
Application.ScreenUpdating = False
L = Cells(Rows.Count, "R").End(xlUp).Row
If Not Intersect(Target, Range("C4")) Is Nothing Then
For Each r In Range("R2:R" & L)
If r.Value = "Y" Then
Rows(r.Row).Hidden = True
Else
Rows(r.Row).Hidden = False
End If
Next
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
There are several techniques that will help speed this up
Writing to .Hidden is much slower than reading it. So check if the row is already hidden or showing before setting Hidden
Collect the rows to Hide or Show into a range (Union) and Hide/Show tehm in one go.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Dim rngCheck As Range
Dim rngHide As Range, rngShow As Range
Application.ScreenUpdating = False
If Not Intersect(Target, Me.Range("C1")) Is Nothing Then
Set rngCheck = Me.Range(Me.Cells(1, "R"), Me.Cells(Me.Rows.Count, "R").End(xlUp))
For Each r In rngCheck.Cells
If r.Value2 = "Y" Then
If Not r.EntireRow.Hidden Then
If rngHide Is Nothing Then
Set rngHide = r.EntireRow
Else
Set rngHide = Union(rngHide, r.EntireRow)
End If
End If
Else
If r.EntireRow.Hidden Then
If rngShow Is Nothing Then
Set rngShow = r.EntireRow
Else
Set rngShow = Union(rngShow, r.EntireRow)
End If
End If
End If
Next
End If
If Not rngHide Is Nothing Then
rngHide.EntireRow.Hidden = True
End If
If Not rngShow Is Nothing Then
rngShow.EntireRow.Hidden = False
End If
Application.ScreenUpdating = True
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'm trying to use a shape instead of a button to toggle hiding rows with blank cells (according to conditions). Is it even possible?
Sub ToggleChevron3_Click()
Dim rng As Range, cell As Range
Set rng = Range("A1:C100")
Application.ScreenUpdating = False
With rng
For Each cell In rng
If cell.Offset(0, 4).Value = "" Then ' Condition 1
If cell.Value = "" Then ' Condition 2
ActiveSheet.Shapes("Chevron 3").cell.EntireRow.Hidden _
= Not ActiveSheet.Shapes("Chevron 3").cell.EntireRow.Hidden
End If
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Yes, it is possible. The code to accomplish what I think you are looking for is below. Both pieces of code below assume you want to just click a button to hide / unhide the rows, depending on the current state.
Sub ToggleChevron3_Click()
Application.ScreenUpdating = False
Dim rng As Range, cell As Range
'Set rng = Range("A1:C100") 'do you really want to loop through every cell in columns A through C
Set rng = Range("A1:A100")
For Each cell In rng
If Len(cell.Offset(, 4).Value) = 0 And Len(cell.Value) = 0 Then
Dim bToggle As Boolean
bToggle = cell.EntireRow.Hidden
cell.EntireRow.Hidden = Not bToggle
End If
Next
Application.ScreenUpdating = True
End Sub
However, there is alternative that is cleaner code and faster execution, as long as filtering is okay for you.
Sub ToggleChevron3_Click()
Application.ScreenUpdating = False
Dim bToggle As Boolean
bToggle = ActiveSheet.AutoFilterMode
If bToggle Then
ActiveSheet.AutoFilterMode = False
Else
Dim rng As Range
Set rng = Range("A1:E100") 'used E because you had an offset of 4 columns
With rng
.AutoFilter 5, "<>"
.AutoFilter 1, "<>"
End With
End If
Application.ScreenUpdating = True
End Sub