I have a short list of values in column K. If I use the Ribbon commands to remove duplicates, Excel removes the duplicates and outputs a message giving the number of duplicates removed:
If I use VBA to do the same thing:
Sub Macro1()
Columns("K:K").Cells.RemoveDuplicates Columns:=1, Header:=xlYes
End Sub
The duplicates are removed, but the message never appears.
How do I get the message to appear if I use the macro ??
MsgBox doesn't allow a lot of room for customization, but setting up a UserForm to look exactly like the Remove Duplicates dialogue would be something you'd have to do on your end, so MsgBox will have to do.
Option Explicit
Sub RemoveDuplicatesWithReport()
Dim unique() As Variant
Dim ws As Worksheet
Dim x As Long, uidCt As Long, dCol As Long, remCt As Long
On Error GoTo ErrorHandler
'turn off screenupdating/calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'current sheet
Set ws = ActiveSheet
'column K
dCol = 11
'resize array for counting uniques
ReDim unique(ws.Cells(ws.Rows.Count, dCol).End(xlUp).Row)
'count how many unique values there are (uidCt)
For x = 2 To ws.Cells(ws.Rows.Count, dCol).End(xlUp).Row
If CountIfArray(ws.Cells(x, dCol), unique()) = 0 Then
unique(uidCt) = ws.Cells(x, dCol).Text
uidCt = uidCt + 1
End If
Next x
'count before removal
remCt = WorksheetFunction.CountA(ws.Columns(dCol)) - 1
'remove duplicates
ws.Columns(dCol).RemoveDuplicates Columns:=1, Header:=xlYes
'count after removal
remCt = remCt - (WorksheetFunction.CountA(ws.Columns(dCol)) - 1)
'turn screenupdating/calculation back on
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
ws.Calculate
'display results
MsgBox remCt & " duplicate values were found and removed." & vbCr & uidCt & " unique values remain.", vbInformation, "Remove Duplicates"
Exit Sub
ErrorHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox Err.Number & vbCr & Err.Description
Exit Sub
End Sub
Public Function CountIfArray(lookup_value, lookup_array)
CountIfArray = Application.Count(Application.Match(lookup_value, lookup_array, 0))
End Function
Related
You may know that Excel has a physical limit of 1 million rows (well, its 1,048,576 rows). I'm trying to TRIM my data containing 1 million rows in the fastest possible way.
Right now I'm using:
Private Sub CommandButton1_Click()
Dim cell As Range
On Error GoTo errHandler
Application.ScreenUpdating = False
For Each cell In ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)
errHandler:
If err.Number = 1004 Then
Exit Sub
End If
cell = WorksheetFunction.Trim(cell)
cell.NumberFormat = "#"
Next cell
Application.ScreenUpdating = True
End Sub
Looing each cell could be avoided. For example,
Sub test()
With Range("A1:A3")
.Value = Evaluate("Trim(" & Range("A1:A3").Address & ")")
End With
End Sub
And if the constant range is nonadjacent then try..
EDIT as per comments below
Private Sub CommandButton1_Click()
Dim rng As Range, ar As Range
Application.ScreenUpdating = False
Set rng = ActiveSheet.ListObjects("Table1") _
.Range.Offset(1).SpecialCells(xlCellTypeConstants)
For Each ar In rng.Areas
ar.Value = Application.Trim(ar)
Next ar
Application.ScreenUpdating = True
End Sub
Solution given by Naresh works well. But you need to change your range to capture complete 1 million+ cells
It took around 5 seconds for me to trim 1 million+ cells
Sub TestTrim()
StartTime = Timer
With Range("A1:A" & Rows.Count)
.Value = Evaluate("Trim(" & Range("A1:A" & Rows.Count).Address & ")")
End With
TotalTime = Timer - StartTime
MsgBox TotalTime & " seconds"
End Sub
I delete rows based on the date in a column.
The dataset is around 85,000 rows and the macro can take from 30s to 5m+ with constant freezing.
I'm not sure if this is due to poorly written code or the size of the dataset.
Sub DeleteCurrentPeriod()
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Worksheets("Transaction list by date")
ws.Activate
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Insert column, autofill formula for range
Sheets("Transaction list by date").Select
Columns("AR:AR").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AR2").Select
ActiveCell.FormulaR1C1 = "=IFERROR(IF(RC[-1]>CONTROL!R20C7,""Y"",""""),"""")"
Selection.AutoFill Destination:=Range("AR2:AR100000"), Type:=xlFillDefault
'Filter on new column for cells matching criteria
ws.Range("$A$1:$BE$100000").AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
On Error Resume Next
Application.DisplayAlerts = False
ws.Range("$A$2:$BE$100000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'Delete added column and remove filter
Columns("AR:AR").Select
Selection.Delete Shift:=xlToLeft
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
Application.ScreenUpdating = True
Application.Goto Reference:=Range("A1")
End Sub
You can give this a try (use F8 key to run it step by step)
Some suggestions:
Name your procedure and variables to something meaningful
Indent your code (you may use Rubberduckvba.com)
Split the logic in steps
Read about avoiding select and activate here
Code:
Public Sub DeleteCurrentPeriod()
On Error GoTo CleanFail
' Turn off stuff
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim transactionSheet As Worksheet
Set transactionSheet = ThisWorkbook.Worksheets("Transaction list by date")
' Turn off autofilter and show all data
transactionSheet.AutoFilterMode = False
' Find last row
Dim lastRow As Long
lastRow = transactionSheet.Cells(transactionSheet.Rows.Count, "AQ").End(xlUp).Row
' Define range to be filtered
Dim targetRange As Range
Set targetRange = transactionSheet.Range("A1:BE" & lastRow)
' Insert column
transactionSheet.Columns("AR:AR").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' Add formula & calculate
transactionSheet.Range("AR2:AR" & lastRow).FormulaR1C1 = "=IFERROR(IF(RC[-1]>CONTROL!R20C7,""Y"",""""),"""")"
Application.Calculate
'Filter on new column for cells matching criteria
transactionSheet.Range("A1:BE" & lastRow).AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
transactionSheet.Range("A2:BE" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
'Delete added column and remove filter
transactionSheet.Columns("AR:AR").Delete Shift:=xlToLeft
' Remove filter
transactionSheet.AutoFilterMode = False
'Select A1
Range("A1").Select
CleanExit:
' Turn on stuff again
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
CleanFail:
MsgBox "An error occurred:" & Err.Description
GoTo CleanExit
End Sub
Let me know if it works
I've just made a couple of changes to how you work out the last row and how you do the calculation, it looks like you were comparing to a constant on the Control sheet. I wonder though why are you adding a column in and then deleting it, could you not just perform the calcs in column +1 after your data? Then you wouldn't have to create and delete the column.
'Insert column, autofill formula for range
Dim x as Long, y, lastrow
Sheets("Transaction list by date").Select
'Find the last row used
With Sheets("Transaction list by date")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
Columns("AR:AR").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AR2").Select
' Get the constant and perform the comparison, add "Y" to TRUE cells
x= Worksheets("Control").Cells(20,7).value
For y = 1 to lastrow
If Worksheets("Transaction list by date").Cells(y,44)>x then _
Worksheets("Transaction list by date").Cells(y,44).value = "Y"
Next y
'Filter on new column for cells matching criteria
ws.Range("$A$1:$BE$" & lastrow ).AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
On Error Resume Next
Application.DisplayAlerts = False
ws.Range("$A$2:$BE$" & lastrow).SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'Delete added column and remove filter
Columns("AR:AR").Select
Selection.Delete Shift:=xlToLeft
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
Application.ScreenUpdating = True
Application.Goto Reference:=Range("A1")
End Sub
Sub RemoveDups()
Const COMPARE_COL As Long = 1
Dim a, aNew(), nr As Long, nc As Long
Dim r As Long, c As Long, rNew As Long
Dim v As String, tmp
a = Worksheets("Sheet1").UsedRange
nr = UBound(a, 1)
nc = UBound(a, 2)
ReDim aNew(1 To nr, 1 To nc)
rNew = 0
v = Date
For r = 1 To nr
tmp = a(r, COMPARE_COL)
If tmp <> v Then
rNew = rNew + 1
For c = 1 To nc
aNew(rNew, c) = a(r, c)
Next c
v = tmp
End If
Next r
Worksheets("Sheet1").UsedRange = aNew
End Sub
This is an answer written by Tim Williams I just set the range to used range and set v to Date, so if you copy and paste this it will search based on the current date you run the macro looking through column 1 (A) If you want to use a different date you'll have to redefine v, you can make that equal to the cell on your control sheet. Took 1 second to "delete" 85000 rows.
I have a spreadsheet which hides all rows except those designated by a date and a named region like so:
'Get week no value...
wk = Range("$B$2").Value
'If value changes...
If Target.Address = "$B$2" Then
'Hide all rows/weeks...
Range("allWeeks").Select
Application.Selection.EntireRow.Hidden = True
'...but show week selected by 'wk'
Range(wk).Select
Application.Selection.EntireRow.Hidden = False
All works great. However. Within each named week I have hidden calculation rows defined by "HC" in column A of the row to be hidden. The display of Range(wk) unhides those hidden rows so I introduce a loop to close all the "HC" hidden columns
Dim x As Integer
For x = 1 To 1500
If Sheet1.Cells(x, 1).Value = "HC" Then
Sheet1.Rows(x).Hidden = True
End If
Next
End Sub
The result is that it kinda works but I have to wait several seconds for the process to complete every time I type into a cell which is making the sheet almost unworkable. Any pointers would be appreciated.
Generally you want to build up a range of rows to hide within the loop and then afterwards hide that range separately. You can build the range to hide using he Union() function like so:
Option Explicit
Sub HideRows()
Dim mainRng As Range
Set mainRng = Range("A2:A" & Range("A" & Rows.count).End(xlUp).Row)
Dim unionRng As Range
Dim i As Long
For i = mainRng.Row To mainRng.Row + mainRng.Rows.count - 1
If Cells(i, 1).Value2 = "HC" Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, Cells(i, 1))
Else
Set unionRng = Cells(i, 1)
End If
End If
Next i
If Not unionRng Is Nothing Then unionRng.EntireRow.Hidden = True
End Sub
Sometimes when you want to update too many things at once, the UI becomes a bit unresponsive.
I've found that disabling UI updates while doing those changes, speeds things up by an order of magnitude:
Sub XXX()
...
On Error GoTo EH
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.StatusBar = "I'm working on it..."
' do lots of changes in cells, rows, sheets...
' Undo the accel changes:
CleanUp:
On Error Resume Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.StatusBar = False
Exit Sub
EH:
' Do error handling
MsgBox "Error found: " & Err.Description
GoTo CleanUp
End Sub
See https://learn.microsoft.com/en-us/office/vba/api/excel.application.screenupdating
and Effect of Screen Updating
I have below vba code to put a formula in cell AE3 then copy down to last row, i have 5000+ rows but wonder why it take so long to process (about 5 min. and still running), is there a better way to do this? i want copy down to last row as the list is dynamic data with different ranges every day. Thanks.
Sub FillRows()
Dim col_AE As String
Sheet1.Select
col_AE = "=IFERROR(INDEX(setting!C[-17],MATCH(smart!RC[-9],setting!C[-18],0)),"""")"
If col_AE <> vbNullString Then
For j = 3 To Range("A" & Rows.Count).End(xlUp).Row - 1
If Range("ae" & j).Value = vbNullString Then
Range("ae" & j).Value = col_AE
End If
Next j
End If
End Sub
You should turn off both ScreenUpdating and Calculations when working with large numbers of formulas.
This line If col_AE <> vbNullString Then isn't doing anything.
Option Explicit
Sub FillRows()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim col_AE As String
With Sheet1
For j = 3 To .Range("A" & .Rows.Count).End(xlUp).Row - 1
If .Range("ae" & j).Value = vbNullString Then
.Range("ae" & j).FormulaR1C1 = "=IFERROR(INDEX(setting!C[-17],MATCH(smart!RC[-9],setting!C[-18],0)),"""")"
End If
Next j
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
The majority of the processing time is being used because the sheet is recalculating every time a formula is added. I would just turn off ScreenUpdating and Calculations and replace all the formulas. In this way I know that the formulas are consistent and that any errors introduced by users would be corrected.
Sub FillRows2()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim col_AE As String
With Sheet1
.Range("A3", "A" & .Rows.Count).End(xlUp).FormulaR1C1 = "=IFERROR(INDEX(setting!C[-17],MATCH(smart!RC[-9],setting!C[-18],0)),"""")"
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
This might speed it up - turn off the screen updating while it is running.
Application.ScreenUpdating = False
Application.ScreenUpdating = True
Please try this:
Option Explicit
Sub fillFormula()
Dim wbk1 As Workbook
Dim lastRow As Long
Set wbk1 = ActiveWorkbook
With wbk1.Sheets("sheet1")
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
lastRow = lastRow - 1
.Range("AE3:AE" & lastRow).Formula = _
"=IFERROR(INDEX(setting!C[-17],MATCH(smart!RC[-9]," _
& "setting!C[-18],0)),"""")"
End With
End Sub
I've been trying to figure this out but no progress...
I have a filter (COLUMN D) and I'm trying to create a loop to each criteria (I got at least 1000 criterias) on my filter.
Ex: For each criteria on filter (column D), I'll run a range copy...
That code isnt working at all:
Sub WhatFilters()
Dim iFilt As Integer
iFilt = 4
Dim iFiltCrit As Integer
Dim numFilters As Integer
Dim crit1 As Variant
ActiveSheet.Range("$A$1:$AA$4635").AutoFilter Field:=16, Criteria1:= _
"Waiting"
numFilters = ActiveSheet.AutoFilter.Filters.Count
Debug.Print "Sheet(" & ActiveSheet.Name & ") has " & numFilters & " filters."
If ActiveSheet.AutoFilter.Filters.Item(iFilt).On Then
crit1 = ActiveSheet.AutoFilter.Filters.Item(iFilt).Criteria1
For iFiltCrit = 1 To UBound(crit1)
Debug.Print "crit1(" & iFiltCrit & ") is '" & crit1(iFiltCrit)
'Copy everything
Next iFiltCrit
End If
End Sub
My mistake seems to be identifying my filter column...
I realize this was asked a while ago but I havent seen anything that I consider copy-paste ready. here is what I came up with. It should work for unlimited criteria. It does create a single new sheet called "temp" that can be deleted once finished.
Dim currentCell As Long
Dim numOfValues As Long
Sub filterNextResult()
' copy and move the data from the data sheet, column A (can be changed if needed) to a new sheet called "temp"
' check to make sure there is at least 1 data point in column A on the temp sheet
If currentCell = 0 Then
Application.ScreenUpdating = False
Call createNewTemp
Application.ScreenUpdating = True
End If
' find the total number of unique data points we will be filtering by in column A of the temp sheet
If numOfAccounts = 0 Then
Application.ScreenUpdating = False
Call findNumOfValues
Application.ScreenUpdating = True
End If
With Sheet1.UsedRange
.AutoFilter 1, Worksheets("temp").Range("A" & currentCell).Value
currentCell = currentCell + 1
' check to make sure we havent reached the end of clumn A. if so exit the sub
If numOfValues + 1 = currentCell Then
MsgBox ("This was the last value to filter by")
Exit Sub
End If
End With
End Sub
'sub that will look for the number of values on the temp sheet column a
Private Sub findNumOfValues()
' count the number of non empty cells and assign that value (less 1 for the title in our case) to the numOfValues
numOfValues = Worksheets("temp").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
End Sub
Private Sub createNewTemp()
Sheet1.Range("A:A").Copy
ActiveWorkbook.Sheets.Add.Name = "temp"
' remove duplicates
Worksheets("temp").Range("A1").Select
With ActiveWorkbook.ActiveSheet
.Paste
.Range("A:A").RemoveDuplicates Columns:=Array(1), Header:=xlYes
End With
' check to make sure there are vlaues in the temp sheet
If Worksheets("temp").Range("A2").Value = "" Then
MsgBox "There are no filter values"
End
Else
currentCell = 2
End If
Sheet1.Activate
Sheet1.Range("A1").Select
Selection.AutoFilter
End Sub
This worked for me
Sub WhatFilters()
Dim iFilt As Integer
Dim i, j As Integer
Dim numFilters As Integer
Dim crit1 As Variant
If Not ActiveSheet.AutoFilterMode Then
Debug.Print "Please enable AutoFilter for the active worksheet"
Exit Sub
End If
numFilters = ActiveSheet.AutoFilter.Filters.Count
Debug.Print "Sheet(" & ActiveSheet.Name & ") has " & numFilters & " filters."
For i = 1 To numFilters
If ActiveSheet.AutoFilter.Filters.Item(i).On Then
crit1 = ActiveSheet.AutoFilter.Filters.Item(i).Criteria1
If IsArray(crit1) Then
'--- multiple criteria are selected in this column
For j = 1 To UBound(crit1)
Debug.Print "crit1(" & i & ") is '" & crit1(j) & "'"
Next j
Else
'--- only a single criteria is selected in this column
Debug.Print "crit1(" & i & ") is '" & crit1 & "'"
End If
End If
Next i
End Sub