Deleting Duplicate Visible Rows - vba

I am trying to use the following VBA code to do two things.
Count the number of unique visible rows in a filtered worksheet.
Delete the duplicate rows
So far:
Function UniqueVisible(MyRange As Range) As Integer
Dim ws As Worksheet
Set ws = Worksheets(1)
Dim R As Range
Dim V() As String
ReDim V(0 To MyRange.Count) As String
For Each R In MyRange
If (R.EntireRow.Hidden = False) Then
For Index = 0 To UniqueVisible
If (V(Index) = R.Value) Then
R.Delete
Exit For
End If
If (Index = UniqueVisible) Then
V(UniqueVisible) = R.Value
UniqueVisible = UniqueVisible + 1
End If
Next
End If
Next R
End Function
This counts okay, and if I replace R.Delete with MsgBox(R.Row) I get the correct row number of the duplicate.
R.Delete does nothing.
R.EntireRow.Delete does nothing
ws.Rows(R.Row).Delete does nothing.
UPDATE
This doesn't seem to be working
Function UniqueVisible(MyRange As Range) As Integer
Dim ws As Worksheet
Set ws = Worksheets(1)
Dim R As Range
Dim Dup As Integer
Dup = 0
Dim Dups() As Integer
ReDim Dups(0 To MyRange.Count) As Integer
Dim V() As String
ReDim V(0 To MyRange.Count) As String
For Each R In MyRange
If (R.EntireRow.Hidden = False) Then
For Index = 0 To UniqueVisible
If (V(Index) = R.Value) Then
Dups(Dup) = R.Row
Dup = Dup + 1
Exit For
End If
If (Index = UniqueVisible) Then
V(UniqueVisible) = R.Value
UniqueVisible = UniqueVisible + 1
End If
Next
End If
Next R
For Each D In Dups
ws.Rows(D).Delete
Next D
End Function

It seems you're breaking a few rules here.
You cannot use a function to delete rows in VBA. It does not matter whether you are using the function as a User Defined Function (aka UDF) on the worksheet or calling it from a sub in a VBA project. A function is meant to return a value, not perform operations that modify the structure (or even the values other than its own cell) on a worksheet. In your case, it could return an array of row numbers to be deleted by a sub.
It is considered canonical practise to start from the bottom (or the right for columns) and work up when deleting rows. Working from the top to the bottom may skip rows when a row is deleted and you loop to the next one.
Here is an example where a sub calls the function to gather the count of the unique, visible entries and an array of rows to be removed.
Sub remove_rows()
Dim v As Long, vDelete_These As Variant, iUnique As Long
Dim ws As Worksheet
Set ws = Worksheets(1)
vDelete_These = UniqueVisible(ws.Range("A1:A20"))
iUnique = vDelete_These(LBound(vDelete_These))
For v = UBound(vDelete_These) To (LBound(vDelete_These) + 1) Step -1 'not that we are working from the bottom up
ws.Rows(vDelete_These(v)).EntireRow.Delete
Next v
Debug.Print "There were " & iUnique & " unique, visible values."
End Sub
Function UniqueVisible(MyRange As Range)
Dim R As Range
Dim uniq As Long
Dim Dups As Variant
Dim v As String
ReDim Dups(1 To 1) 'make room for the unique count
v = ChrW(8203) 'seed out string hash check with the delimiter
For Each R In MyRange
If Not R.EntireRow.Hidden Then
If CBool(InStr(1, v, ChrW(8203) & R.Value & ChrW(8203), vbTextCompare)) Then
ReDim Preserve Dups(1 To UBound(Dups) + 1)
Dups(UBound(Dups)) = R.Row
Else
uniq = uniq + 1
v = v & R.Value & ChrW(8203)
End If
End If
Next R
Dups(LBound(Dups)) = uniq 'stuff the unique count into the primary of the array
UniqueVisible = Dups
End Function
Now, that is probably not how I would go about it. Seems easier to just write the whole thing into a single sub. However, understanding processes and limitations is important so I hope you can work with this.
Note that this does not have any error control. This should be present when dealing with arrays and deleting row in loops.

You can't delete a row while you're looping through the rows. You'll need to store the rows that need to be deleted in an array, and then loop through the array and delete the rows after it's done looping through the rows.

Related

VBA Rows.Count in Selection

I'm looking to work out how many rows a user has selected to be displayed at the top of the sheet next to an action button, I.e. Button says "Generate Email" and next to it says "x items selected".
As this is updated everytime the selection is changed, I have the following code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Sheet1.Range("E1") = Target.Rows.Count & " items selected"
End Sub
This works fine if the user selects consecutive rows, for e.g. 7:10 returns 4.
My problem is if a user selected rows 7, and 10. It would only return 1 (the rows in the first part of the selection).
From what I've found, there is no way of just getting this value from a property, but I can't get my head around how to iterate through all parts of the selection/target and calculate the sum of rows. Then there is also the possibility that the user selects say A7, C7, and A10. A7 and C7 relate to the same item, so this should only really be treated as one, not two, which I think my hypothetical code would do...
Has anyone tried to achieve this before and been successful or could point me in the direction of some properties which may help? I tried a separate function to achieve it, but that wasn't working either.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Sheet1.Range("E1") = getRowCount(Target) & " items selected"
End Sub
Function getRowCount(selectedRanges As Ranges)
rowCount = 0
For Each subRange In selectedRanges
rowCount = rowCount + subRange.Rows.Count
Next
getRowCount = rowCount
End Function
I think this will work. (Did when I tried it.)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Create a range containing just column A
Dim subRange As Range
Dim r As Range
For Each subRange In Target.Areas
If r Is Nothing Then
Set r = subRange.EntireRow.Columns(1)
Else
Set r = Union(r, subRange.EntireRow.Columns(1))
End If
Next
'Count how many cells in the combined column A range
Sheet1.Range("E1") = r.Cells.Count & " items selected"
End Sub
You need to count the rows in each Area the user has selected.
https://msdn.microsoft.com/en-us/vba/excel-vba/articles/range-areas-property-excel
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rArea As Range
Dim lCount As Long
For Each rArea In Selection.Areas
lCount = lCount + rArea.Rows.Count
Next rArea
Sheet1.Range("E1") = lCount
End Sub
Sub NumberOfRowsSelected()
Dim vMatch As Variant, aRows() As Long, r As Range, x As Long
ReDim Preserve aRows(x)
aRows(x) = 0
For Each r In Selection.Cells
vMatch = Application.Match(r.Row, aRows, 0)
If IsError(vMatch) Then
x = x + 1
ReDim Preserve aRows(0 To x)
aRows(x) = r.Row
End If
Next r
MsgBox UBound(aRows)
End Sub
Revised Code Converted as Function
Sub NumberOfRowsSelected()
MsgBox RowsCount(Selection)
End Sub
Function RowsCount(rRange As Range) As Long
Dim vMatch As Variant, aRows() As Long, r As Range, x As Long
ReDim Preserve aRows(x)
aRows(x) = 0
For Each r In rRange.Cells
vMatch = Application.Match(r.Row, aRows, 0)
If IsError(vMatch) Then
x = x + 1
ReDim Preserve aRows(0 To x)
aRows(x) = r.Row
End If
Next r
RowsCount = UBound(aRows)
End Function
A different method, building up a string of checked rows seems pretty straight-forward to avoid double counting. See comments for details:
Function getRowCount(rng As Range) As Long
Dim c As Range
' Keep track of which rows we've already counted
Dim countedrows As String: countedrows = ","
' Loop over cells in range
For Each c In rng
' Check if already counted
If Not InStr(countedrows, "," & c.Row & ",") > 0 Then
' Add to counted list
countedrows = countedrows & c.Row & ","
End If
Next c
' Get number of rows counted
Dim rowsarr() As String: rowsarr = Split(countedrows, ",")
getRowCount = UBound(rowsarr) - LBound(rowsarr) - 1
End Function
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cell As Range
Dim i, currentRow As Long: i = 0
'get row of first cell in range
currentRow = Target.Cells(1, 1).row
For Each cell In Target
'if row is different, then increase number of items, as it's next item
If Not currentRow = cell.row Then
i = i + 1
currentRow = cell.row
End If
Next cell
Range("E1").Value = i
End Sub

VBA Output new collection to single cell

I need to get unique values from a range, in a specific cell.
A1=x, A2=y, A3=z, A4=x
I want to get B1=x,y,z
My solution is:
concatenate A1,A2,A3,A4, in B2.
split B2.
make new collection from splitted B2.
output collection elements into C1, C2, ..Ci
concatenate C1, C2,..Ci into B1
Is possible to avoid to output collection into C1,C2 ? but output directly into B1 through some variable ?
'''''''
concatenation part
''''''''
Dim ary As Variant
Dim Arr As New Collection, a
Dim i As Long
ary = split(Range("b2"), ",")
For Each a In ary
Arr.Add a, a
Next
For i = 1 To Arr.count
Cells(1, i+2) = Arr(i) ' output collection in some cells
Next
'''''''''''''''''''''''''
concatenation part
'''''''''''
Thank you.
you could use a late binding "on the fly" Dictionary object:
Sub main()
Dim cell As Range
With CreateObject("Scripting.Dictionary")
For Each cell In Range("A1:A4") '<--| change "A1:A4" to whatever range you need
.Item(cell.Value) = .Item(cell.Value) + 1
Next cell
Range("B1").Value = Join(.keys, ",")
End With
End Sub
in the array, split again, spit(a,"=") adding index 1 to another array, not a collection, then use JOIN to put it back together
x=0
redim arrOutput(ubound(ary))
For Each a In ary
arrOutput(x)= split(a,"=")(1)
x=x+1
Next
range("b1")=join(arrOutput,",")
or just split by = and take odd numbers from the resulting array maybe?
If you need to hold something unique - always think about dictionary, cause of Exists method. Here's a small example:
Sub test()
Dim NonUniqueValues As Variant
Dim UniqueValues As Object
Dim i As Long
'gather source array
NonUniqueValues = Union([A1], [A2], [A3], [A4]).Value2
'set dict
Set UniqueValues = CreateObject("Scripting.Dictionary")
'loop over array
For i = LBound(NonUniqueValues, 1) To UBound(NonUniqueValues, 1)
If Not UniqueValues.Exists(NonUniqueValues(i, 1)) Then _
Call UniqueValues.Add(Key:=NonUniqueValues(i, 1), Item:=NonUniqueValues(i, 1))
Next
'output
[B1] = Join(UniqueValues.Keys, ",")
End Sub
Perhaps:
Public Function KonKat(rng As Range) As String
Dim c As Collection, r As Range, i As Long
Set c = New Collection
On Error Resume Next
For Each r In rng
c.Add r.Value, CStr(r.Value)
Next r
On Error GoTo 0
For i = 1 To c.Count
KonKat = KonKat & "," & c.Item(i)
Next i
KonKat = Mid(KonKat, 2)
End Function

Accessing the Index of Non-Contiguous Visible Cells

I have a data table that filters a column, "Product", based on the user's autofilter selections. I also have "Product" defined as a dynamically named range, which we'll define as A2:A30 for this example. Afterward, I would like to further manipulate the visible cells. A snippet of my debugging code:
Dim xName As Range
Set xName = ThisWorkbook.Names("Product").RefersToRange.SpecialCells(xlCellTypeVisible)
Debug.Print xName.Count
Debug.Print xName(3)
xName.Count would always return the correct number of visible cells, but accessing the index of xName proves troublesome when dealing with non-contiguous hidden cells. For instance, if A2:A5 and A8:A11 are the hidden cells, xName(1) would return A6's value, but xName(3) would return A8's value instead of A12's value. This makes it near impossible for me to loop through just the visible cells.
Is there an index manipulation I can do to only work with visible cells? Any help would be appreciated!
For non-contiguous ranges you can loop using For Each.
E.g.
Sub Tester()
Dim rng As Range, rw As Range
'create a non-contiguous test range
Set rng = Range("A3:D4,A7:D7,A10:D16")
'loop over each row in the range
For Each rw In rng.Rows
Debug.Print rw.Address()
Next rw
End Sub
My suggestion:
Sub test()
Dim xName As Range
Set xName = ThisWorkbook.Names("Product").RefersToRange.SpecialCells(xlCellTypeVisible)
Debug.Print xName.Count
Debug.Print VisibleCell(xName, 3)
End Sub
Function VisibleCell(rng As Range, index As Long) As Range
Dim i As Long
Dim r As Long
i = 0
r = 1
Do
Do While rng(r).EntireRow.RowHeight = 0 Or rng(r).EntireColumn.ColumnWidth = 0
r = r + 1
Loop
i = i + 1
If i = index Then
Set VisibleCell = rng(r)
Exit Do
End If
r = r + 1
Loop
End Function
Maybe this is what you want to do: iterate over the areas of the range because it has been split into many areas due to the hidden ranges.
Set xName =ThisWorkbook.Names("Product").RefersToRange.SpecialCells(xlCellTypeVisible)
For i = 1 to xName.Areas.Count
For j = 1 to XName.Areas(i).Count
Debug.Print i, j, XName.Areas(i).Cells(j)
Next
Next

Search in Excel using VBA

I need to search a worksheet by a particular value in a specific column. I have to do something with values in other columns of the found rows. What is the most simple and efficient way to get all row numbers that have the search value in that specific column?
Thanks.
You could try something like that:
Public Function Test(str As String, rng As Range) As Variant
Dim xVal As Variant, Arr() As Variant
Dim i As Long
ReDim Arr(0 To 100)
For Each xVal In rng
If xVal.Value = str Then
Arr(i) = xVal.Row
i = i + 1
End If
Next
If i Then
ReDim Preserve Arr(0 To i - 1)
Test = Arr
Else
Test = 0
End If
End Function
(Done by phone. May contain errors.)
If you are looking for happiness in some region of a worksheet, the select that region and run:
Sub FindingHappiness()
Dim s As String, rng As Range, r As Range
Dim msg As String
Set rng = Intersect(Selection, ActiveSheet.UsedRange)
s = "happiness"
For Each r In rng
If InStr(1, r.Text, s) > 0 Then
msg = msg & vbCrLf & r.Row
End If
Next r
MsgBox msg
End Sub
Note that using this technique will allow you to search in a single row, or in a single column, or in a block of cells, or all the cells on a worksheet, or even in a disjoint group of cells.

Fast way to loop through filtered list in reverse?

I have a sheet with a large number of auto-filtered rows (>200,000). I'm trying loop 'upwards' through a column until I find the first cell that's different from the current cell. I can loop 'downwards' through through visible cells by using:
For Each cl In rng.SpecialCells(xlCellTypeVisible)
'check for different value
Next cl
I can also loop 'upwards' skipping over hidden rows using:
For i = rng.Count To 1 Step -1
If rng.Cells(i).EntireRow.Hidden Then
'do nothing
ElseIf 'check different value
End If
Next i
But with a large number of hidden rows this can take a while to skip over all of them even if there are only a couple of hundred visible rows. I've tried using rng.SpecialCells(xlCellTypeVisible) and stepping backwards through them but it seems to also go through hidden cells.
Is there a way to reverse the order of a For Each loop?
Is there a faster way to do this?
Thanks
Sub Tester()
Dim x As Long, n As Long
Dim a() As Long
Dim rng As Range, c As Range, vis As Range
Dim sht As Worksheet
Set sht = ActiveSheet
Set rng = sht.Range("A1:A1000")
Set vis = rng.SpecialCells(xlCellTypeVisible)
n = vis.Cells.Count
ReDim a(1 To n)
x = 1
For Each c In vis.Cells
a(x) = c.Row
x = x + 1
Next c
For x = n To 1 Step -1
Debug.Print a(x), sht.Cells(a(x), 1)
Next x
End Sub
You could build a Collection of the visible cells and then extract them in reverse:
Sub Backwards()
Dim N As Long, col As Collection, RR As Range, r As Range
Dim i As Long
Set RR = Intersect(ActiveSheet.UsedRange, Range("A:A").Cells.SpecialCells(xlCellTypeVisible))
Set col = New Collection
For Each r In RR
col.Add (r.Address)
Next r
N = col.Count
For i = N To 1 Step -1
Set r = Range(col(i))
MsgBox r.Address
Next i
End Sub