Related
Summary. I am trying to loop through a table and delete each row if a particular substring is found in a specified column. I am specifically stuck on the line of code that finds the target text, which I know to be incorrect, but cannot find the proper syntax for what I'm trying to achieve: If tbl.DataBodyRange(rw, 10).Find(myString)
I have searched many websites and YouTube videos, and there are a few that address finding an exact value, but nothing I could find like the problem I'm trying to solve.
My code:
Sub removeTax()
Dim tbl As ListObject
Set tbl = ThisWorkbook.Sheets("Master").ListObjects("tblMaster")
Dim myString As String
myString = "Tax"
Dim rw
For rw = tbl.DataBodyRange.Rows.Count To 1 Step -1
If tbl.DataBodyRange(rw, 10).Find(myString) Then
tbl.ListRows.Delete
End If
Next
End Sub
Thank you very much for any assistance you can offer.
Delete Criteria Rows of an Excel Table (ListObject)
As an alternative, this uses a method that uses AutoFilter and SpecialCells.
Usage
Sub RemoveTax()
Const CritColumn As Long = 10
Const CritString As String = "*Tax*" ' contains
Dim tbl As ListObject
Set tbl = ThisWorkbook.Worksheets("Master").ListObjects("tblMaster")
DeleteTableCriteriaRows tbl, CritColumn, CritString
End Sub
The Method
Sub DeleteTableCriteriaRows( _
ByVal Table As ListObject, _
ByVal CriteriaColumn As String, _
ByVal CriteriaString As String)
With Table
If .ShowAutoFilter Then
If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
Else
.ShowAutoFilter = True
End If
.Range.AutoFilter CriteriaColumn, CriteriaString
Dim rg As Range
On Error Resume Next
Set rg = .DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter.ShowAllData
If Not rg Is Nothing Then rg.Delete xlShiftUp
End With
End Sub
I've corrected your approach, it checks if myString is sub-string of values in column 10
With tbl.DataBodyRange.Columns(10)
For rw = .Rows.Count To 1 Step -1
If InStr(1, .Cells(rw).Value2, myString) > 0 Then
tbl.ListRows(rw).Delete
End If
Next rw
End With
Keep in mind, you should check if tbl.DataBodyRange is not Nothing, before doing anything with it, since deleting all rows of a table makes DataBodyRange be equal to Nothing
I've decided to make a bit more efficient solution, more to my liking
Sub RemoveTaxQuicker()
Const myString = "Tax"
Dim tbl As ListObject
Set tbl = ThisWorkbook.Sheets("Master").ListObjects("tblMaster")
If tbl.DataBodyRange Is Nothing Then: Exit Sub
Dim rowsRangeString As String
Dim i As Long
Dim C10 As Variant
C10 = tbl.DataBodyRange.Columns(10).Value2
Dim rng As Range
If IsArray(C10) Then
Set rng = Nothing
For i = LBound(C10) To UBound(C10)
If InStr(1, C10(i, 1), myString) > 0 Then
If rng Is Nothing Then
Set rng = tbl.DataBodyRange.Cells(i, 1)
Else
Set rng = Union(rng, tbl.DataBodyRange.Cells(i, 1))
End If
End If
Next i
If Not rng Is Nothing Then
rng.Delete xlUp
End If
ElseIf InStr(1, C10, myString) > 0 Then
tbl.ListRows(1).Delete
End If
End Sub
This is no longer true :) You should use #VBasic2008 approach, I've tested it on 500k rows and it takes around 10 sec or so. And I had to test mine as well (was painfully long), it took ~5 mins. :)
Okay VBasic2008's solution forced me to think about this in a different way. The following solution executes almost instantly.
'works with formulas as well with some exceptions, thanks VBasic for pointing that as a potential problem
Sub RemoveTaxQuicker2()
Const myString = "Tax"
Const COLUMN = 10
Dim tbl As ListObject
Set tbl = ThisWorkbook.Sheets("Master").ListObjects("tblMaster")
If tbl.DataBodyRange Is Nothing Then: Exit Sub
Dim i As Long, j As Long
Dim count As Long
Dim sDataBody As Variant
Dim sFormulas As Variant
sDataBody = tbl.DataBodyRange.Formula
sFormulas = tbl.ListRows(1).Range.Formula
If tbl.DataBodyRange.Rows.count > 1 Then
For i = LBound(sDataBody, 1) To UBound(sDataBody, 1)
If InStr(1, sDataBody(i, COLUMN), myString) < 1 Then
count = count + 1
For j = LBound(sDataBody, 2) To UBound(sDataBody, 2)
sDataBody(count, j) = sDataBody(i, j)
Next j
End If
Next i
If count > 0 Then
For i = LBound(sFormulas, 2) To UBound(sFormulas, 2)
If Left$(sFormulas(1, i), 1) = "=" Then
sDataBody(1, i) = sFormulas(1, i)
End If
Next i
tbl.DataBodyRange.Formula = sDataBody
If tbl.ListRows.count > count Then
tbl.ListRows(count + 1).Range.Resize(tbl.ListRows.count).ClearContents
tbl.Resize tbl.Range.Resize(count + 1)
End If
End If
ElseIf InStr(1, sDataBody(1, COLUMN), myString) > 0 Then
On Error Resume Next
tbl.DataBodyRange.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End If
End Sub
Final note: I still prefer VBasic's method, if nothing else it's much cleaner and it works when the table is full of formulas that are not auto-filled :)
I'm putting together a spreadsheet that should populate checkboxes in a specific column when the spreadsheet opens if the appropriate A Column/Row is not empty. It should also remove checkboxes when it finds that same A column to be empty. My VB is correctly creating the checkboxes, but I cannot figure out how to tell the code to delete the checkbox from a specific cell.
Most articles I find mention removed ALL checkboxes, but I'm looking to do it conditionally. Any guidance would be greatly appreciated.
Private Sub Workbook_Open()
'declare a variable
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
'calculate if a cell is not blank across a range of cells with a For Loop
For x = 2 To 1000
If ws.Cells(x, 1) <> "" Then
Call Add_CheckBox(CInt(x))
Else
Call Delete_CheckBox(CInt(x))
End If
Next x
End Sub
Private Sub Add_CheckBox(Row As Integer)
ActiveSheet.CheckBoxes.Add(Cells(Row, "T").Left, Cells(Row, "T").Top, 72, 12.75).Select
With Selection
.Caption = ""
.Value = xlOff '
.LinkedCell = "AA" & Row
.Display3DShading = False
End With
End Sub
Private Sub Delete_CheckBox(Row As Integer)
Dim cb As CheckBox
If cb.TopLeftCell.Address = (Row, "T") Then cb.Delete
End Sub
Naming the CheckBoxes will make it easier to maintain your code.
Private Sub Workbook_Open()
Const CheckBoxPrefix As String = "Sheet1TColumnCheckBox"
'declare a variable
Dim CheckBoxName As String
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
'calculate if a cell is not blank across a range of cells with a For Loop
Dim r As Long
For r = 2 To 1000
CheckBoxName = CheckBoxPrefix & r
If Len(ws.Cells(r, 1)) > 0 Then
If Not WorksheetContainsCheckBox(CheckBoxName, ws) Then Add_CheckBox CheckBoxName, ws.Cells(r, 1), ws.Cells(r, "AA")
Else
If WorksheetContainsCheckBox(CheckBoxName, ws) Then ws.CheckBoxes(CheckBoxName).Delete
End If
Next
End Sub
Private Sub Add_CheckBox(CheckBoxName As String, Cell As Range, LinkedCell As Range)
With Cell.Worksheet.CheckBoxes.Add(Cell.Left, Cell.Top, 72, 12.75)
.Caption = ""
.Value = xlOff '
.LinkedCell = LinkedCell
.Display3DShading = False
.Name = CheckBoxName
End With
End Sub
Function WorksheetContainsCheckBox(CheckBoxName As String, ws As Worksheet)
Dim CheckBox As Object
On Error Resume Next
Set CheckBox = ws.CheckBoxes(CheckBoxName)
WorksheetContainsCheckBox = Err.Number = 0
On Error GoTo 0
End Function
Try something like this (put a checkbox "in" A1 but not C1)
Sub tester()
Debug.Print Delete_CheckBox([A1])
Debug.Print Delete_CheckBox([C1])
End Sub
'Return True if able to delete a checkbox from range `rng`
Private Function Delete_CheckBox(rng As Range) As Boolean
Dim cb As CheckBox
For Each cb In rng.Worksheet.CheckBoxes
If Not Application.Intersect(cb.TopLeftCell, rng) Is Nothing Then
Debug.Print "Deleting checkbox in " & cb.TopLeftCell.Address
cb.Delete
Delete_CheckBox = True
Exit For 'if only expecting one matched checkbox
End If
Next cb
End Function
I want to add data to last row in each table in each worksheet when the worksheet is protected.
I have this code in ThisWorkbook to protect the worksheets
Private Sub Workbook_Open()
Dim wSheet As Worksheet
For Each wSheet In Worksheets
wSheet.Protect Password:="Secret", _
UserInterFaceOnly:=True
Next wSheet
End Sub
and the following code to add the data. It throws
Error 1004 "Application-defined or Object-defined error"
at the Set newrow1 = tbl.ListRows.Add when the worksheet is protected.
Sub AddDataToTable()
Application.ScreenUpdating = False
Dim MyValue As String
Dim sh As Worksheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
Dim ws5 As Worksheet
Set ws1 = Sheets("Setting")
Set ws2 = Sheets("R_Buy")
Set ws3 = Sheets("R_Sell")
Set ws4 = Sheets("S_Buy")
Set ws5 = Sheets("S_Sell")
Dim tbl As ListObject
Dim tb2 As ListObject
Dim tb3 As ListObject
Dim tb4 As ListObject
Dim tb5 As ListObject
Set tbl = ws1.ListObjects("T_Setting")
Set tb2 = ws2.ListObjects("T_R_Buy")
Set tb3 = ws3.ListObjects("T_R_Sell")
Set tb4 = ws4.ListObjects("T_S_Buy")
Set tb5 = ws5.ListObjects("T_S_Sell")
Dim newrow1 As ListRow
Dim newrow2 As ListRow
Dim newrow3 As ListRow
Dim newrow4 As ListRow
Dim newrow5 As ListRow
MyValue = InputBox("Add To Table, this cannot be undone")
'check if user clicked Cancel button and, if appropriate, execute statements
If StrPtr(MyValue) = 0 Then
'display message box confirming that user clicked Cancel button
MsgBox "You clicked the Cancel button"
'check if user entered no input and, if appropriate, execute statements
ElseIf MyValue = "" Then
'display message box confirming that user entered no input
MsgBox "There is no Text Input"
Else
Set newrow1 = tbl.ListRows.Add
With newrow1
.Range(1) = MyValue
End With
Set newrow2 = tb2.ListRows.Add
With newrow2
.Range(1) = MyValue
End With
Set newrow3 = tb3.ListRows.Add
With newrow3
.Range(1) = MyValue
End With
Set newrow4 = tb4.ListRows.Add
With newrow4
.Range(1) = MyValue
End With
Set newrow5 = tb5.ListRows.Add
With newrow5
.Range(1) = MyValue
End With
End If
Application.ScreenUpdating = True
End Sub
That's an issue with Excel that it doesn't allow to edit tables in UserInterFaceOnly:=True mode. Unfortunately, the only workaround I've found is to unprotect before any table methods are applied and then reprotect after:
.Unprotect Password:=SHEET_PW 'unprotect sheet
'edit table
.Protect Password:=SHEET_PW, UserInterFaceOnly:=True 'reprotect
Additionally I suggest the following improvement to shorten your code:
Use arrays Dim tbl(1 To 5) instead of multiple variables tbl1, tbl2, tbl3, …
Or better use an array to list your worksheet names only.
Use more descriptive variable names (makes your life easier to maintain and read the code)
If your table names are always T_ followed by the worksheet name you can easily generate them out of your worksheet name.
Use a constant for your worksheet password SHEET_PW to have it stored in only one place (easier to change, prevents typos).
Use loops to do repetitive things.
So we end up with:
Option Explicit
Const SHEET_PW As String = "Secret" 'global password for protecting worksheets
Public Sub AddDataToTableImproved()
Dim AddValue As String
AddValue = InputBox("Add To Table, this cannot be undone")
If StrPtr(AddValue) = 0 Then 'cancel button
MsgBox "You clicked the Cancel button"
Exit Sub
ElseIf AddValue = "" Then 'no input
MsgBox "There is no Text Input"
Exit Sub
End If
Dim NewRow As ListRow
Dim SheetNameList() As Variant
SheetNameList = Array("Setting", "R_Buy", "R_Sell", "S_Buy", "S_Sell")
Dim SheetName As Variant
For Each SheetName In SheetNameList
With ThisWorkbook.Worksheets(SheetName)
.Unprotect Password:=SHEET_PW 'unprotect sheet
Set NewRow = .ListObjects("T_" & SheetName).ListRows.Add
NewRow.Range(1) = AddValue
.Protect Password:=SHEET_PW, UserInterFaceOnly:=True 'reprotect it
End With
Next SheetName
End Sub
A bit late to help the original OP but hopefully this will help other readers.
There is indeed an issue with the ListObject functionality when the worksheet is protected even if the UserInterFaceOnly flag is set to True.
However, we can still use the Range and Application functionality and we can actually work around most of the use cases with the exception of 2 edge cases:
We want to insert immediately after the header row AND the sheet is protected AND the headers are off (.ShowHeaders is False) - I don't think there is any solution to this but to be honest I wonder why would one have the headers off. Not to mention it's a really rare case to meet all 3 criterias.
The table has no rows AND the sheet is protected AND the headers are off. In this case the special 'insert' row cannot easily be turned into a 'listrow' but it can be done with a few column and row inserts - not worth the trouble though as this is potentially rare in real life use.
Here is the code that I came up with:
Option Explicit
Option Private Module
Private Const MODULE_NAME As String = "LibExcelListObjects"
'*******************************************************************************
'Adds rows to a ListObject and returns the corresponding added Range
'Parameters:
' - tbl: the table to add rows to
' - [rowsToAdd]: the number of rows to add. Default is 1
' - [startRow]: the row index from where to start adding. Default is 0 in
' which case the rows would be appended at the end of the table
' - [doEntireSheetRow]:
' * TRUE - adds entire rows including left and right of the target table
' * FALSE - adds rows only below the table bounds shifting down (default)
'Raises error:
' - 5: if 'rowsToAdd' is less than 1
' - 9: if 'startRow' is invalid
' - 91: if 'tbl' is not set
' - 1004: if adding rows failed due to worksheet being protected while the
' UserInterfaceOnly flag is set to False
'*******************************************************************************
Public Function AddListRows(ByVal tbl As ListObject _
, Optional ByVal rowsToAdd As Long = 1 _
, Optional ByVal startRow As Long = 0 _
, Optional ByVal doEntireSheetRow As Boolean = False _
) As Range
Const fullMethodName As String = MODULE_NAME & ".AddListRows"
Dim isSuccess As Boolean
'
If tbl Is Nothing Then
Err.Raise 91, fullMethodName, "Table object not set"
ElseIf startRow < 0 Or startRow > tbl.ListRows.Count + 1 Then
Err.Raise 9, fullMethodName, "Invalid start row index"
ElseIf rowsToAdd < 1 Then
Err.Raise 5, fullMethodName, "Invalid number of rows to add"
End If
If startRow = 0 Then startRow = tbl.ListRows.Count + 1
'
If startRow = tbl.ListRows.Count + 1 Then
isSuccess = AppendListRows(tbl, rowsToAdd, doEntireSheetRow)
Else
isSuccess = InsertListRows(tbl, rowsToAdd, startRow, doEntireSheetRow)
End If
If Not isSuccess Then
If tbl.Parent.ProtectContents And Not tbl.Parent.ProtectionMode Then
Err.Raise 1004, fullMethodName, "Parent sheet is macro protected"
Else
Err.Raise 5, fullMethodName, "Cannot append rows"
End If
End If
Set AddListRows = tbl.ListRows(startRow).Range.Resize(RowSize:=rowsToAdd)
End Function
'*******************************************************************************
'Utility for 'AddListRows' method
'Inserts rows into a ListObject. Does not append!
'*******************************************************************************
Private Function InsertListRows(ByVal tbl As ListObject _
, ByVal rowsToInsert As Long _
, ByVal startRow As Long _
, ByVal doEntireSheetRow As Boolean) As Boolean
Dim rngInsert As Range
Dim fOrigin As XlInsertFormatOrigin: fOrigin = xlFormatFromLeftOrAbove
Dim needsHeaders As Boolean
'
If startRow = 1 Then
If Not tbl.ShowHeaders Then
If tbl.Parent.ProtectContents Then
Exit Function 'Not sure possible without headers
Else
needsHeaders = True
End If
End If
fOrigin = xlFormatFromRightOrBelow
End If
'
Set rngInsert = tbl.ListRows(startRow).Range.Resize(RowSize:=rowsToInsert)
If doEntireSheetRow Then Set rngInsert = rngInsert.EntireRow
'
On Error Resume Next
If needsHeaders Then tbl.ShowHeaders = True
rngInsert.Insert xlShiftDown, fOrigin
If needsHeaders Then tbl.ShowHeaders = False
InsertListRows = (Err.Number = 0)
On Error GoTo 0
End Function
'*******************************************************************************
'Utility for 'AddListRows' method
'Appends rows to the bottom of a ListObject. Does not insert!
'*******************************************************************************
Private Function AppendListRows(ByVal tbl As ListObject _
, ByVal rowsToAppend As Long _
, ByVal doEntireSheetRow As Boolean) As Boolean
If tbl.ListRows.Count = 0 Then
If Not UpgradeInsertRow(tbl) Then Exit Function
If rowsToAppend = 1 Then
AppendListRows = True
Exit Function
End If
rowsToAppend = rowsToAppend - 1
End If
'
Dim rngToAppend As Range
Dim isProtected As Boolean: isProtected = tbl.Parent.ProtectContents
'
On Error GoTo ErrorHandler
If isProtected And tbl.ShowTotals Then
Set rngToAppend = tbl.TotalsRowRange
ElseIf isProtected Then
Set rngToAppend = AutoExpandOneRow(tbl)
Else
Set rngToAppend = tbl.Range.Rows(tbl.Range.Rows.Count + 1)
End If
'
Set rngToAppend = rngToAppend.Resize(RowSize:=rowsToAppend)
If doEntireSheetRow Then Set rngToAppend = rngToAppend.EntireRow
rngToAppend.Insert xlShiftDown, xlFormatFromLeftOrAbove
'
If isProtected And tbl.ShowTotals Then 'Fix formatting
tbl.ListRows(1).Range.Copy
With tbl.ListRows(tbl.ListRows.Count - rowsToAppend + 1).Range
.Resize(RowSize:=rowsToAppend).PasteSpecial xlPasteFormats
End With
ElseIf isProtected Then 'Delete the autoExpand row
tbl.ListRows(tbl.ListRows.Count).Range.Delete xlShiftUp
Else 'Resize table
tbl.Resize tbl.Range.Resize(tbl.Range.Rows.Count + rowsToAppend)
End If
AppendListRows = True
Exit Function
ErrorHandler:
AppendListRows = False
End Function
'*******************************************************************************
'Utility for 'AppendListRows' method
'Transforms the Insert row into a usable ListRow
'*******************************************************************************
Private Function UpgradeInsertRow(ByVal tbl As ListObject) As Boolean
If tbl.InsertRowRange Is Nothing Then Exit Function
If tbl.Parent.ProtectContents And Not tbl.ShowHeaders Then
Exit Function 'Not implemented - can be done using a few inserts
Else
Dim needsHeaders As Boolean: needsHeaders = Not tbl.ShowHeaders
'
If needsHeaders Then tbl.ShowHeaders = True
tbl.InsertRowRange.Insert xlShiftDown, xlFormatFromLeftOrAbove
If needsHeaders Then tbl.ShowHeaders = False
End If
UpgradeInsertRow = True
End Function
'*******************************************************************************
'Utility for 'AppendListRows' method
'Adds one row via auto expand if the worksheet is protected and totals are off
'*******************************************************************************
Private Function AutoExpandOneRow(ByVal tbl As ListObject) As Range
If Not tbl.Parent.ProtectContents Then Exit Function
If tbl.ShowTotals Then Exit Function
'
Dim ac As AutoCorrect: Set ac = Application.AutoCorrect
Dim isAutoExpand As Boolean: isAutoExpand = ac.AutoExpandListRange
Dim tempRow As Range: Set tempRow = tbl.Range.Rows(tbl.Range.Rows.Count + 1)
'
If Not isAutoExpand Then ac.AutoExpandListRange = True
tempRow.Insert xlShiftDown, xlFormatFromLeftOrAbove
Set AutoExpandOneRow = tempRow.Offset(-1, 0)
Const arbitraryValue As Long = 1 'Must not be Empty/Null/""
AutoExpandOneRow.Value2 = arbitraryValue 'AutoExpand is triggered
If Not isAutoExpand Then ac.AutoExpandListRange = False 'Revert if needed
End Function
Assuming tbl is a variable holding the table, we can use the above like this:
AddListRows tbl 'Adds 1 row at the end
AddListRows tbl, 5 'Adds 5 rows at the end
AddListRows tbl, 3, 2 'Inserts 3 rows at index 2
AddListRows tbl, 1, 3, True 'Insert one row at index 3 but for the whole sheet
As long as the UserInterfaceOnly flag is set to True the above will work except the 2 edge cases I mentioned at the beginning of the answer. Of course, the operation would fail if there is another ListObject immediately below the table we want to insert into but that would fail anyway even if the sheet was unprotected.
One nice advantage is that the AddListRows method above returns the range that was inserted so that it can be used to write data immediately after the rows were added.
I have code that would compare each cell in column A to everything in column B and do this for the number of lines specified.
This was fine when I had a couple hundred lines, but now I am finding with 2000 lines the code is just not going to cut it. Can anyone look at my code and tell me if there are some improvements to be made or if I should scrap it and do it differently.
Sub highlight()
Dim compare As String
Dim i As Integer
Dim comprange As Range
Dim lines As Integer
i = 2
ScreenUpdating = False
Range("a2").Select
lines = Application.InputBox(Prompt:="How many lines need to be compared?",
_
Title:="SPECIFY RANGE", Type:=1)
Do Until IsEmpty(ActiveCell)
If i + 1 > lines Then
Exit Do
End If
Set comprange = Range("A" & i)
comprange.Select
compare = comprange.Value
i = i + 1
Range("B2").Select
Do Until IsEmpty(ActiveCell.Offset(1, 0))
If ActiveCell.Value = compare Then
ActiveCell.Interior.ColorIndex = 37
ActiveCell.Offset(1, 0).Select
Exit Do
Else
If IsEmpty(ActiveCell.Offset(1, 0)) Then
Exit Do
Else
ActiveCell.Offset(1, 0).Select
End If
End If
Loop
Loop
compare = ActiveCell.Value
Set comprange = Selection
Range("a2").Select
Do Until IsEmpty(ActiveCell.Offset(1, 0))
If ActiveCell.Value = compare Then
comprange.Interior.ColorIndex = 37
ActiveCell.Offset(1, 0).Select
Exit Do
Else
If IsEmpty(ActiveCell.Offset(1, 0)) Then
Exit Do
Else
ActiveCell.Offset(1, 0).Select
End If
End If
Loop
End Sub
Try this, it will check ALL your values in column A and if it matches in column B hightlights.
Sub ok()
Dim i, i2 As Long
Dim LastRow, LastRow2 As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With ActiveSheet
LastRow2 = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
For i = 1 To LastRow
For i2 = 1 To LastRow2
If Range("A" & i).Value = Range("B" & i2).Value Then
Range("A" & i).Interior.ColorIndex = 37
Range("B" & i2).Interior.ColorIndex = 37
End If
Next
Next
End Sub
Probably the most efficient way to do this is to use the VBA Dictionary object. There's a great article at https://www.experts-exchange.com/articles/3391/Using-the-Dictionary-Class-in-VBA.html that covers a lot of what you need to know.
Below is a function called DuplicatesBetweenLists that will highlight duplicates between any number of different ranges. When calling it, you can specify:
A range to dump a list of duplicates into (pass in an empty range if you don't want a list generated)
Whether or not you want the duplicate items highlighted
A ParamArray (Comma-separated list) of all the ranges you want to check.
So if you wanted to check all three of columns in the image below for entries that occur in each column, and wanted to output a list to cell E1 of any duplicates as well as highlight them in the data, you'd call the function like this:
Sub test()
Dim rOutput As Range
Set rOutput = Range("E1")
DuplicatesBetweenLists rOutput, True, Range("A2:A11"), Range("B2:B11"), Range("C2:C11")
End Sub
...which would give you something like this:
But if you only wanted highlighting and didn't want the identified duplicates output to a range, you'd simply comment out the Set rOutput = Range("E1") line, and pass in an empty range as the first argument.
It is lightning fast compared to a brute force iteration approach: it handled 2 lists containing 2000 items in less than a second (vs 1 minute for the brute force approach). And it handles 2 lists of 200,000 items in just 12 seconds.
And here's the function itself, as well as another function it calls:
Function DuplicatesBetweenLists(rOutput As Range, bHighlight As Boolean, ParamArray Ranges() As Variant)
Dim vRange As Variant
Dim vInput As Variant
Dim dic_A As Object
Dim dic_B As Object
Dim dic_Output As Object
Dim lOutput As Long
Dim lRange As Long
Dim cell As Range
Dim TimeTaken As Date
TimeTaken = Now()
Set dic_A = CreateObject("Scripting.Dictionary")
Set dic_B = CreateObject("Scripting.Dictionary")
Set dic_Output = CreateObject("Scripting.Dictionary")
Set dic_Range = CreateObject("Scripting.Dictionary")
lRange = 1
For Each vRange In Ranges
vInput = vRange
DuplicatesBetweenLists_AddToDictionary vInput, lRange, dic_A, dic_B
Next vRange
If lRange Mod 2 = 1 Then
Set dic_Output = dic_B
Else: Set dic_Output = dic_A
End If
'Write any duplicate items back to the worksheet
If Not rOutput Is Nothing Then
If dic_Output.Count > 0 Then
If dic_Output.Count < 65537 Then
rOutput.Resize(dic_Output.Count) = Application.Transpose(dic_Output.Items)
Else
'The dictionary is too big to transfer to the workheet
'because Application.Transfer can't handle more than 65536 items.
'So well transfer it to an appropriately oriented variant array,
' then transfer that array to the worksheet WITHOUT application.transpose
ReDim varOutput(1 To dic_Output.Count, 1 To 1)
For Each vItem In dic_Output
lOutput = lOutput + 1
varOutput(lOutput, 1) = vItem
Next vItem
rOutput.Resize(dic_Output.Count) = varOutput
End If
End If
End If
'Highlight any duplicates
If bHighlight Then
'Highlight cells in the range that qualify
Application.ScreenUpdating = False
For Each vRange In Ranges
'Set rInput = vRange
vRange.Interior.ColorIndex = 0
For Each cell In vRange
With cell
If dic_Output.Exists(.Value2) Then .Interior.Color = 65535
End With
Next cell
Next vRange
Application.ScreenUpdating = True
TimeTaken = TimeTaken - Now()
Debug.Print Format(TimeTaken, "HH:MM:SS") & "(HH:MM:SS)"
End If
'Cleanup
Set dic_A = Nothing
Set dic_B = Nothing
Set dic_Output = Nothing
End Function
Private Function DuplicatesBetweenLists_AddToDictionary(varItems As Variant, ByRef lngRange As Long, ByVal dic_A As Object, ByVal dic_B As Object)
Dim lng As Long
Dim dic_dedup As Object
Dim varItem As Variant
Dim lPass As Long
Set dic_dedup = CreateObject("Scripting.Dictionary")
For lPass = 1 To UBound(varItems, 2)
If lngRange = 1 Then
'First Pass: Just add the items to dic_A
For lng = 1 To UBound(varItems)
If Not dic_A.Exists(varItems(lng, 1)) Then dic_A.Add varItems(lng, 1), varItems(lng, 1)
Next
Else:
' Add items from current pass to dic_Dedup so we can get rid of any duplicates within the column.
' Without this step, the code further below would think that intra-column duplicates were in fact
' duplicates ACROSS the columns processed to date
For lng = 1 To UBound(varItems)
If Not dic_dedup.Exists(varItems(lng, lPass)) Then dic_dedup.Add varItems(lng, lPass), varItems(lng, lPass)
Next
'Find out which Dictionary currently contains our identified duplicate.
' This changes with each pass.
' * On the first pass, we add the first list to dic_A
' * On the 2nd pass, we attempt to add each new item to dic_A.
' If an item already exists in dic_A then we know it's a duplicate
' between lists, and so we add it to dic_B.
' When we've processed that list, we clear dic_A
' * On the 3rd pass, we attempt to add each new item to dic_B,
' to see if it matches any of the duplicates already identified.
' If an item already exists in dic_B then we know it's a duplicate
' across all the lists we've processed to date, and so we add it to dic_A.
' When we've processed that list, we clear dic_B
' * We keep on doing this until the user presses CANCEL.
If lngRange Mod 2 = 0 Then
'dic_A currently contains any duplicate items we've found in our passes to date
'Test if item appears in dic_A, and IF SO then add it to dic_B
For Each varItem In dic_dedup
If dic_A.Exists(varItem) Then
If Not dic_B.Exists(varItem) Then dic_B.Add varItem, varItem
End If
Next
dic_A.RemoveAll
dic_dedup.RemoveAll
Else 'dic_B currently contains any duplicate items we've found in our passes to date
'Test if item appear in dic_B, and IF SO then add it to dic_A
For Each varItem In dic_dedup
If dic_B.Exists(varItem) Then
If Not dic_A.Exists(varItem) Then dic_A.Add varItem, varItem
End If
Next
dic_B.RemoveAll
dic_dedup.RemoveAll
End If
End If
lngRange = lngRange + 1
Next
End Function
I have an excel workbook that needs to allow the user to undo multiple changes within a worksheet. I have searched online in every forum that I can think of and have not been able to find an answer for this. I realize that there is an issue with the undo issue in excel when macro's are run, and have been able to handle this using code derived from here.
This is my current process:
Create global variables to hold the initial state of the workbook, and the changes. Code is as follows:
Private Type SaveRange
Val As Variant
Addr As String
End Type
Private OldWorkbook As Workbook
Private OldSheet As Worksheet
Private OldSelection() As SaveRange
Private OldSelectionCount As Integer
Private InitialState() As SaveRange
Private InitialStateCount As Integer
Get the initial state of the workbook by building an array (InitialState) holding the values of all the cells in the Workbook_Open sub. Code is as follows:
Private Sub Workbook_Open()
GetInitialCellState
End Sub
Private Sub GetInitialCellState()
Dim i As Integer, j As Integer, count As Integer
Dim cellVal As String
Dim sampID As Range, cell As Range
Dim e1664 As Workbook
Dim rawData As Worksheet
Dim table As Range
Dim LastRow As Integer, LastCol As Integer
LastRow = Worksheets("Raw_Data").Range("A65536").End(xlUp).Row
LastCol = Worksheets("Raw_Data").UsedRange.Columns.count
Set e1664 = ThisWorkbook
Set rawData = e1664.Sheets("Raw_Data")
Set sampID = rawData.Range("SAMPLEID").Offset(1)
Set table = rawData.Range(sampID, "R" & LastRow)
i = 0
j = 0
count = 0
ReDim InitialState(i)
For i = 0 To (LastRow - sampID.Row)
For j = 0 To LastCol
ReDim Preserve InitialState(count)
InitialState(count).Addr = sampID.Offset(i, j).address
InitialState(count).Val = sampID.Offset(i, j).Value
count = count + 1
Next j
Next i
InitialStateCount = count - 1
End Sub
When a value is entered into a cell, store the value entered into another array (OldSelection) holding the value entered. This is done in the Workbook_Change sub. The important parts here are the Call SaveState(OldSelectionCount, Target.Cells.address, Target.Cells.Value) and Application.OnUndo "Undo the last action", "GI.OR.E1664.20150915_DRAFT.xlt!Sheet1.RevertState" pieces which are shown in numbers 4 and 5 below. Code is as follows:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range, InWtRange As Boolean
Dim y As Integer, x As Integer, count As Integer
Dim LastRow As Integer
'This saves the changed values of the cells
Call SaveState(OldSelectionCount, Target.Cells.address, Target.Cells.Value)
try:
y = Me.Range("SampleID").Row
If Target.Column > 5 And Target.Column < 8 Then
If Range("A" & Target.Row).Value = Range("A" & Target.Row + 1).Value Then
If Range("A" & Target.Row + 1).Value <> "" Then
Range(Target.address).Offset(1).Value = Range(Target.address).Value
End If
End If
Else
'If initial pan weight add start date
If Target.Column = 8 Then
If Target.Cells.Text <> "" Then
If Not IsNumeric(Target.Cells.Value) Then
GoTo Finally
Else
Application.EnableEvents = False
Range("StartDate").Offset(Target.Cells.Row - y).Value = Format(Now(), "MM/DD/YY HH:NN:SS")
Application.EnableEvents = True
End If
Else
Application.EnableEvents = False
Range("StartDate").Offset(Target.Cells.Row - y).Value = ""
Application.EnableEvents = True
End If
End If
End If
LastRow = Worksheets("Raw_Data").Range("A65536").End(xlUp).Row
For Each cell In Target.Cells
'Debug.Print Target.Cells.Address
If cell.Value <> "" Then
If Not IsNumeric(cell.Value) Then GoTo Finally
Select Case cell.Column
Case 9, 11, 13
Application.EnableEvents = False
If CalcHEM(cell.Row - y, cell.Column) Then
End If
Application.EnableEvents = True
Case Else
'Do nothing yet
End Select
'Cells(Target.Row + 1, Target.Column).Select
End If
Next
'This will allow the changed values to be undone
Application.OnUndo "Undo the last action", "GI.OR.E1664.20150915_DRAFT.xlt!Sheet1.RevertState"
Finally:
If Application.EnableEvents = False Then Application.EnableEvents = True
Exit Sub
Catch:
MsgBox "An error has occurred in the code execution." & vbNewLine _
& "The message text of the error is: " & Error(Err), vbInformation, "TSSCalcs.AddQC"
Resume Finally
End Sub
The SaveState Sub will save add to the OldSelection array, any values that have changed. Code is as follows:
Private Sub SaveState(count As Integer, Addr As String, Val As Double)
Dim i As Integer
Dim cell As Range
If TypeName(Selection) <> "Range" Or Selection.count > 1 Then Exit Sub
ReDim Preserve OldSelection(count)
Set OldWorkbook = ActiveWorkbook
Set OldSheet = ActiveSheet
For Each cell In Selection
OldSelection(count).Addr = Addr
OldSelection(count).Val = Val
Next cell
OldSelectionCount = OldSelectionCount + 1
End Sub
The RevertState Sub will undo ONLY THE LAST ACTION! I am unable to allow more than the last entry to be undone. Code is as follows:
Private Sub RevertState()
Dim i As Integer, index As Integer
Dim prevItem As SaveRange
Dim address As String
OldWorkbook.Activate
OldSheet.Activate
Application.EnableEvents = False
address = OldSelection(OldSelectionCount - 1).Addr
OldSelectionCount = OldSelectionCount - 2
If OldSelectionCount <= 0 Then
ReDim OldSelection(0)
For i = 0 To InitialStateCount
If InitialState(i).Addr = address Then
prevItem.Val = InitialState(i).Val
index = i
End If
Next i
Range(InitialState(index).Addr).Formula = prevItem.Val
Else
ReDim Preserve OldSelection(OldSelectionCount)
For i = 0 To OldSelectionCount
If OldSelection(i).Addr = address Then
prevItem.Val = OldSelection(i).Val
index = i
End If
Next i
'OldSelectionCount = OldSelectionCount + 1
Range(OldSelection(index).Addr).Formula = prevItem.Val
End If
OldSelectionCount = OldSelectionCount + 1
Application.EnableEvents = True
End Sub
Does anyone know of a way to allow multiple undo's to be done?
Any help to solve this issue would be greatly appreciated!
After researching the Undo function on MSDN here, I found that the Application.Undo function only undoes the last action taken by the user. Instead of trying to get Microsoft's undo functionality to work, I have added my own undo and redo buttons which function the same as Microsoft's buttons. I have added two class modules: ActionState (holds the properties for workbook, worksheet, address and value of a cell)
ActionStates (a collection ActionState objects along with functions for adding, removing, getting an item, clearing the collection, counting, and properties for the CurrentState, and InitialState of the worksheet).
The new process is as follows:
Get the initial state of all the cells in the worksheet and add these to the undo stack array (see GetInitialCellStates() method within UndoFuntionality module).
When an item is added to a cell, add the address and value to the array (see SaveState() method within UndoFunctionality module) and update the index of the current state to the most recently added value. Repeat this step with any additional values.
When this is done, it enables the undo button.
If the undo button is pressed, it will decrement the index of the current state and enable the redo button (see RevertState() function within UndoFunctionality module).
If the redo button is pressed it will increment the index of the current state (see ProgressState() function within UndoFunctionality module).
The code for the ActionState class is as follows:
Private asAddr As String
Private asVal As Variant
Private asWorkbook As Workbook
Private asWorksheet As Worksheet
Private Sub Class_Initalize()
Set asWorkbook = New Workbook
Set asWorksheet = New Worksheet
End Sub
'''''''''''''''''''
' Addr property
'''''''''''''''''''
Public Property Get Addr() As String
Addr = asAddr
End Property
Public Property Let Addr(Value As String)
asAddr = Value
End Property
'''''''''''''''''''
' Val property
'''''''''''''''''''
Public Property Get Val() As Variant
Val = asVal
End Property
Public Property Let Val(Value As Variant)
asVal = Value
End Property
'''''''''''''''''''
' Wkbook property
'''''''''''''''''''
Public Property Get Wkbook() As Workbook
Set Wkbook = asWorkbook
End Property
Public Property Let Wkbook(Value As Workbook)
Set asWorkbook = Value
End Property
'''''''''''''''''''
' WkSheet property
'''''''''''''''''''
Public Property Get Wksheet() As Worksheet
Set Wksheet = asWorksheet
End Property
Public Property Let Wksheet(Value As Worksheet)
Set asWorksheet = Value
End Property
The code for the ActionStates class is as follows:
Private asStates As Collection
Private currState As Integer
Private initState As Integer
Private Sub Class_Initialize()
Set asStates = New Collection
End Sub
Private Sub Class_Termitate()
Set asStates = Nothing
End Sub
''''''''''''''''''''''''''''
' InitialState property
''''''''''''''''''''''''''''
Public Property Get InitialState() As Integer
InitialState = initState
End Property
Public Property Let InitialState(Value As Integer)
initState = Value
End Property
''''''''''''''''''''''''''''
' CurrentState property
''''''''''''''''''''''''''''
Public Property Get CurrentState() As Integer
CurrentState = currState
End Property
Public Property Let CurrentState(Value As Integer)
currState = Value
End Property
''''''''''''''''''''''''''''
' Add method
''''''''''''''''''''''''''''
Public Function Add(Addr As String, Val As Variant) As clsActionState
Dim asNew As New clsActionState
With asNew
.Addr = Addr
.Val = Val
End With
asStates.Add asNew
End Function
''''''''''''''''''''''''''''
' Count method
''''''''''''''''''''''''''''
Public Property Get count() As Long
If TypeName(asStates) = "Nothing" Then
Set asStates = New Collection
End If
count = asStates.count
End Property
''''''''''''''''''''''''''''
' Item method
''''''''''''''''''''''''''''
Public Function Item(index As Integer) As clsActionState
Set Item = asStates.Item(index)
End Function
''''''''''''''''''''''''''''
' Remove method
''''''''''''''''''''''''''''
Public Function Remove(index As Integer)
If TypeName(asStates) = "Nothing" Then
Set asStates = New Collection
End If
asStates.Remove (index)
End Function
''''''''''''''''''''''''''''
' Clear method
''''''''''''''''''''''''''''
Public Sub Clear()
Dim x As Integer
For x = 1 To asStates.count
asStates.Remove (1)
Next x
End Sub
These two classes are used in a new module called UndoFunctionality as follows:
Option Explicit
Public ActionState As New clsActionState
Public ActionStates As New clsActionStates
Public undoChange As Boolean
Public Sub SaveState(count As Integer, Addr As String, Val As Variant)
Dim i As Integer
Dim cell As Range
If TypeName(Selection) <> "Range" Or Selection.count > 1 Then Exit Sub
With ActionState
.Wkbook = ActiveWorkbook
.Wksheet = ActiveSheet
End With
If ActionStates.CurrentState < ActionStates.count Then
For i = ActionStates.CurrentState + 1 To ActionStates.count
ActionStates.Remove (ActionStates.count)
Next i
End If
For Each cell In Selection
ActionState.Addr = Addr
ActionState.Val = Val
Next cell
ActionStates.Add ActionState.Addr, ActionState.Val
ActionStates.CurrentState = ActionStates.count
End Sub
Public Sub RevertState()
Dim i As Integer, index As Integer
Dim prevItem As New clsActionState
Dim Address As String
'undoChange = True
With ActionState
.Wkbook.Activate
.Wksheet.Activate
End With
Application.EnableEvents = False
Address = ActionStates.Item(ActionStates.CurrentState).Addr
ActionStates.CurrentState = ActionStates.CurrentState - 1
For i = 1 To ActionStates.CurrentState
If ActionStates.Item(i).Addr = Address Then
prevItem.Val = ActionStates.Item(i).Val
index = i
End If
Next i
Range(ActionStates.Item(index).Addr).Formula = prevItem.Val
Application.EnableEvents = True
UndoButtonAvailability
RedoButtonAvailability
End Sub
Public Sub ProgressState()
Dim i As Integer, index As Integer
Dim nextItem As New clsActionState
Dim Address As String
With ActionState
.Wkbook.Activate
.Wksheet.Activate
End With
Application.EnableEvents = False
ActionStates.CurrentState = ActionStates.CurrentState + 1
With nextItem
.Addr = ActionStates.Item(ActionStates.CurrentState).Addr
.Val = ActionStates.Item(ActionStates.CurrentState).Val
End With
Range(ActionStates.Item(ActionStates.CurrentState).Addr).Formula = nextItem.Val
Application.EnableEvents = True
UndoButtonAvailability
RedoButtonAvailability
End Sub
Public Sub GetInitialCellStates()
Dim i As Integer, j As Integer, count As Integer
Dim cellVal As String
Dim sampID As Range, cell As Range
Dim e1664 As Workbook
Dim rawData As Worksheet
Dim table As Range
Dim LastRow As Integer, LastCol As Integer
ThisWorkbook.Worksheets("Raw_Data").Activate
If ActionStates.count > 0 Then
ActionStates.Clear
End If
LastRow = Worksheets("Raw_Data").Range("A65536").End(xlUp).Row
LastCol = Worksheets("Raw_Data").UsedRange.Columns.count
Set e1664 = ThisWorkbook
Set rawData = e1664.Sheets("Raw_Data")
Set sampID = rawData.Range("SAMPLEID").Offset(1)
Set table = rawData.Range(sampID, "R" & LastRow)
i = 0
j = 0
count = 0
For i = 0 To (LastRow - sampID.Row)
For j = 0 To LastCol
ActionState.Addr = sampID.Offset(i, j).Address
ActionState.Val = sampID.Offset(i, j).Value
ActionStates.Add ActionState.Addr, ActionState.Val
count = count + 1
Next j
Next i
ActionStates.InitialState = count
ActionStates.CurrentState = count
undoChange = False
UndoButtonAvailability
RedoButtonAvailability
End Sub
Public Sub UndoButtonAvailability()
Dim rawData As Worksheet
Set rawData = ThisWorkbook.Sheets("Raw_Data")
If ActionStates.CurrentState <= ActionStates.InitialState Then
rawData.Buttons("UndoButton").Enabled = False
rawData.Buttons("UndoButton").Font.ColorIndex = 16
Else
rawData.Buttons("UndoButton").Enabled = True
rawData.Buttons("UndoButton").Font.ColorIndex = 1
End If
End Sub
Public Sub RedoButtonAvailability()
Dim rawData As Worksheet
Set rawData = ThisWorkbook.Sheets("Raw_Data")
If ActionStates.CurrentState < ActionStates.count Then
rawData.Buttons("RedoButton").Enabled = True
rawData.Buttons("RedoButton").Font.ColorIndex = 1
Else
rawData.Buttons("RedoButton").Enabled = False
rawData.Buttons("RedoButton").Font.ColorIndex = 16
End If
End Sub
Sub UndoButton_Click()
Dim rawData As Worksheet
Set rawData = ThisWorkbook.Sheets("Raw_Data")
If rawData.Buttons("UndoButton").Enabled Then
RevertState
End If
End Sub
Sub RedoButton_Click()
Dim rawData As Worksheet
Set rawData = ThisWorkbook.Sheets("Raw_Data")
If rawData.Buttons("RedoButton").Enabled Then
ProgressState
End If
End Sub
The GetInitialStates method is used in the workbook_open event as follows:
UndoFunctionality.GetInitialCellStates
And the Worksheet_Change event within the worksheet is as follows:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range, InWtRange As Boolean
Dim y As Integer, x As Integer, count As Integer
Dim LastRow As Integer
'This saves the changed values of the cells
Call SaveState(ActionStates.CurrentState, Target.Cells.Address, Target.Cells.Value)
try:
y = Me.Range("SampleID").Row
If Target.Column > 5 And Target.Column < 8 Then
If Range("A" & Target.Row).Value = Range("A" & Target.Row + 1).Value Then
If Range("A" & Target.Row + 1).Value <> "" Then
Range(Target.Address).Offset(1).Value = Range(Target.Address).Value
End If
End If
Else
'If initial pan weight add start date
If Target.Column = 8 Then
If Target.Cells.Text <> "" Then
If Not IsNumeric(Target.Cells.Value) Then
GoTo Finally
Else
Application.EnableEvents = False
Range("StartDate").Offset(Target.Cells.Row - y).Value = Format(Now(), "MM/DD/YY HH:NN:SS")
Application.EnableEvents = True
End If
Else
Application.EnableEvents = False
Range("StartDate").Offset(Target.Cells.Row - y).Value = ""
Application.EnableEvents = True
End If
End If
End If
LastRow = Worksheets("Raw_Data").Range("A65536").End(xlUp).Row
For Each cell In Target.Cells
If cell.Value <> "" Then
If Not IsNumeric(cell.Value) Then GoTo Finally
Select Case cell.Column
Case 9, 11, 13
Application.EnableEvents = False
If CalcHEM(cell.Row - y, cell.Column) Then
End If
Application.EnableEvents = True
Case Else
'Do nothing yet
End Select
End If
Next
UndoFunctionality.UndoButtonAvailability
UndoFunctionality.RedoButtonAvailability
Finally:
If Application.EnableEvents = False Then Application.EnableEvents = True
Exit Sub
Catch:
MsgBox "An error has occurred in the code execution." & vbNewLine _
& "The message text of the error is: " & Error(Err), vbInformation, "TSSCalcs.AddQC"
Resume Finally
End Sub
The only thing left is to add two buttons to the worksheet and assign the macro used to the UndoButton_Click() and RedoButton_Click() events which will run the RevertState() and ProgressState() methods.
I found a little trick using Application.OnTime. So it is possible to use Undo repeatedly.
The Repeat button is not the Redo button. You can find it in the Edit menu or put it on your ribbon.
I am using Excel 2003.
Here is a working sample. Put the code inside ThisWorkbook module.
Dim Undos As New Collection
Sub Change()
' push previous cell values to the end of your undo array
Undos.Add ActiveCell.Value
' change the cell values as you wish
ActiveCell.Value = "(" + ActiveCell.Value + ")"
PlanUndo
PlanRepeat
End Sub
Sub Undo()
' make sure the undo array is not empty
If (Undos.Count > 0) Then
' pop previous cell values from the end of your undo array
Dim Value
Value = Undos.Item(Undos.Count)
Undos.Remove Undos.Count
' revert the cell values
ActiveCell.Value = Value
End If
If (Undos.Count > 0) Then
PlanUndo
End If
PlanRepeat
End Sub
Function PlanUndo()
Application.OnTime Now, "ThisWorkbook.SetUndo"
End Function
Sub SetUndo()
Application.OnUndo "Undo last change", "ThisWorkbook.Undo"
End Sub
Function PlanRepeat()
Application.OnTime Now, "ThisWorkbook.SetRepeat"
End Function
Sub SetRepeat()
Application.OnRepeat "Repeat last change", "ThisWorkbook.Change"
End Sub