Trying to make some code that filters the unique rows in a range, but only
leaves the visible row, making it just as a normal range. So, no blue row
numbers and continuous row numbering without gaps.
Something like this will do it, but I think there must be a shorter more
elegant way:

Sub test()
FilterUniqueInRange ActiveSheet, ActiveWindow.RangeSelection
End Sub


Sub FilterUniqueInRange(sh As Worksheet, rng As Range)

Dim arr
Dim shTemp

sh.Activate
rng.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
ActiveWindow.RangeSelection.Copy

Set shTemp =
ActiveWorkbook.Sheets.Add(after:=Worksheets(Worksh eets.Count))
shTemp.Name = "tempPaste"
shTemp.Activate
ActiveSheet.Paste
Application.CutCopyMode = False

With sh
.ShowAllData
.Cells.Clear
End With

ActiveWindow.RangeSelection.Copy

sh.Activate
Cells(1).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Application.DisplayAlerts = False
shTemp.Delete
Application.DisplayAlerts = True

End Sub


RBS

RBS,

Since you are clearing all the cells on the original sheet why not...
Regards,
Jim Cone
San Francisco, USA

'-------------------
Sub test()
FilterUniqueInRange ActiveSheet, ActiveWindow.RangeSelection
End Sub

Sub FilterUniqueInRange(sh As Worksheet, rng As Range)
Dim strName As String
Dim shTemp

sh.Activate
strName = sh.Name
rng.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
ActiveWindow.RangeSelection.Copy

Set shTemp = _
ActiveWorkbook.Sheets.Add(after:=Worksheets(strNam e))
shTemp.Paste
Application.CutCopyMode = False


Application.DisplayAlerts = False
sh.Delete
shTemp.Name = strName
Application.DisplayAlerts = True
Set shTemp = Nothing
End Sub
'-------------------------------


"RB Smissaert"

wrote in message

Trying to make some code that filters the unique rows in a range, but only
leaves the visible row, making it just as a normal range. So, no blue row
numbers and continuous row numbering without gaps.
Something like this will do it, but I think there must be a shorter more
elegant way:
Sub test()
FilterUniqueInRange ActiveSheet, ActiveWindow.RangeSelection
End Sub

Sub FilterUniqueInRange(sh As Worksheet, rng As Range)
Dim arr
Dim shTemp

sh.Activate
rng.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
ActiveWindow.RangeSelection.Copy

Set shTemp =
ActiveWorkbook.Sheets.Add(after:=Worksheets(Worksh eets.Count))
shTemp.Name = "tempPaste"
shTemp.Activate
ActiveSheet.Paste
Application.CutCopyMode = False

With sh
.ShowAllData
.Cells.Clear
End With

ActiveWindow.RangeSelection.Copy

sh.Activate
Cells(1).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Application.DisplayAlerts = False
shTemp.Delete
Application.DisplayAlerts = True
End Sub
RBS

Jim,

Yes, that is a bit neater indeed.
I was hoping though that there might be a way to do away
with the temp worksheet, although it is not really a problem.

RBS


"Jim Cone" wrote in message
...
RBS,

Since you are clearing all the cells on the original sheet why not...
Regards,
Jim Cone
San Francisco, USA

'-------------------
Sub test()
FilterUniqueInRange ActiveSheet, ActiveWindow.RangeSelection
End Sub

Sub FilterUniqueInRange(sh As Worksheet, rng As Range)
Dim strName As String
Dim shTemp

sh.Activate
strName = sh.Name
rng.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
ActiveWindow.RangeSelection.Copy

Set shTemp = _
ActiveWorkbook.Sheets.Add(after:=Worksheets(strNam e))
shTemp.Paste
Application.CutCopyMode = False


Application.DisplayAlerts = False
sh.Delete
shTemp.Name = strName
Application.DisplayAlerts = True
Set shTemp = Nothing
End Sub
'-------------------------------


"RB Smissaert"

wrote in message

Trying to make some code that filters the unique rows in a range, but only
leaves the visible row, making it just as a normal range. So, no blue row
numbers and continuous row numbering without gaps.
Something like this will do it, but I think there must be a shorter more
elegant way:
Sub test()
FilterUniqueInRange ActiveSheet, ActiveWindow.RangeSelection
End Sub

Sub FilterUniqueInRange(sh As Worksheet, rng As Range)
Dim arr
Dim shTemp

sh.Activate
rng.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
ActiveWindow.RangeSelection.Copy

Set shTemp =
ActiveWorkbook.Sheets.Add(after:=Worksheets(Worksh eets.Count))
shTemp.Name = "tempPaste"
shTemp.Activate
ActiveSheet.Paste
Application.CutCopyMode = False

With sh
.ShowAllData
.Cells.Clear
End With

ActiveWindow.RangeSelection.Copy

sh.Activate
Cells(1).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Application.DisplayAlerts = False
shTemp.Delete
Application.DisplayAlerts = True
End Sub
RBS

RBS,

I did play around with using only the original sheet.
However, it involved...
Using SpecialCells to get the visible range.
Looping thru each range area and writing each cell value to an array.
Placing the array on the sheet.
It wasn't very neat.

The following is an amended version of my earlier post that
is a little more compact...
Regards,
Jim Cone
San Francisco, USA

'---------------------------
Sub test()
FilterUniqueInRange ActiveSheet, ActiveWindow.RangeSelection
End Sub
'---
Sub FilterUniqueInRange(sh As Worksheet, rng As Range)
Dim strName As String
Dim shtTemp

strName = sh.Name
Set shtTemp = _
ActiveWorkbook.Sheets.Add(after:=Worksheets(strNam e), Count:=1)
sh.Activate
rng.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=shtTemp.Range(rng(1).Address), Unique:=True

Application.DisplayAlerts = False
sh.Delete
shtTemp.Name = strName
Application.DisplayAlerts = True
Set shtTemp = Nothing
End Sub
'---------------------------


"RB Smissaert"

wrote in message

Jim,
Yes, that is a bit neater indeed.
I was hoping though that there might be a way to do away
with the temp worksheet, although it is not really a problem.
RBS

Jim,

A bit neater again, but maybe it has to be done the messy way as I noticed
objects in the sheet are lost.
Although it is a lot more code, maybe there are advantages to do this
without the filter altogether.
So get the range in an array, filter the unique rows in the array and put it
back.
The one advantage I can see is that you do it case sensitive and case
in-sensitive.
The drawback would be it that if the range is large it might get a bit slow.

RBS



"Jim Cone" wrote in message
...
RBS,

I did play around with using only the original sheet.
However, it involved...
Using SpecialCells to get the visible range.
Looping thru each range area and writing each cell value to an array.
Placing the array on the sheet.
It wasn't very neat.

The following is an amended version of my earlier post that
is a little more compact...
Regards,
Jim Cone
San Francisco, USA

'---------------------------
Sub test()
FilterUniqueInRange ActiveSheet, ActiveWindow.RangeSelection
End Sub
'---
Sub FilterUniqueInRange(sh As Worksheet, rng As Range)
Dim strName As String
Dim shtTemp

strName = sh.Name
Set shtTemp = _
ActiveWorkbook.Sheets.Add(after:=Worksheets(strNam e), Count:=1)
sh.Activate
rng.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=shtTemp.Range(rng(1).Address), Unique:=True

Application.DisplayAlerts = False
sh.Delete
shtTemp.Name = strName
Application.DisplayAlerts = True
Set shtTemp = Nothing
End Sub
'---------------------------


"RB Smissaert"

wrote in message

Jim,
Yes, that is a bit neater indeed.
I was hoping though that there might be a way to do away
with the temp worksheet, although it is not really a problem.
RBS

Hi Bart,

Have you thought of adding a helper column with formula (this assumes
looking for duplicates in A2 down) -

=COUNTIF($A$2:A2,A2)1

Use "autofill" to copy down to the last row
Add an Auto filter top of this column, filter True and delete entire rows of
the filter range.
Could use the hidden sheet name "_Filterdatabase" (starting one row down
from the top if necessary).

Regards,
Peter T

"RB Smissaert" wrote in message
...
Jim,

A bit neater again, but maybe it has to be done the messy way as I noticed
objects in the sheet are lost.
Although it is a lot more code, maybe there are advantages to do this
without the filter altogether.
So get the range in an array, filter the unique rows in the array and put
it
back.
The one advantage I can see is that you do it case sensitive and case
in-sensitive.
The drawback would be it that if the range is large it might get a bit
slow.

RBS



"Jim Cone" wrote in message
...
RBS,

I did play around with using only the original sheet.
However, it involved...
Using SpecialCells to get the visible range.
Looping thru each range area and writing each cell value to an array.
Placing the array on the sheet.
It wasn't very neat.

The following is an amended version of my earlier post that
is a little more compact...
Regards,
Jim Cone
San Francisco, USA

'---------------------------
Sub test()
FilterUniqueInRange ActiveSheet, ActiveWindow.RangeSelection
End Sub
'---
Sub FilterUniqueInRange(sh As Worksheet, rng As Range)
Dim strName As String
Dim shtTemp

strName = sh.Name
Set shtTemp = _
ActiveWorkbook.Sheets.Add(after:=Worksheets(strNam e), Count:=1)
sh.Activate
rng.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=shtTemp.Range(rng(1).Address), Unique:=True

Application.DisplayAlerts = False
sh.Delete
shtTemp.Name = strName
Application.DisplayAlerts = True
Set shtTemp = Nothing
End Sub
'---------------------------


"RB Smissaert"

wrote in message

Jim,
Yes, that is a bit neater indeed.
I was hoping though that there might be a way to do away
with the temp worksheet, although it is not really a problem.
RBS

I had in mind something like -

Option Explicit

Sub Testit()
Dim rng As Range
Dim nLastrow As Long

MakeDups

nLastrow = Range("A2").End(xlDown).Row
Set rng = Range(Cells(1, 1), Cells(nLastrow, 1))

DelDupRows rng, nLastrow

End Sub

Sub DelDupRows(rData As Range, lLast As Long)
Dim bTopRow
Dim nCol As Long
Dim sFmla As String
Dim nFcnt As Long
Dim rTmp As Range
Dim ws As Worksheet

Set ws = rData.Parent

'assumes rData does NOT start in row 1

With ws.UsedRange
nCol = .Columns.Count + .Columns(1).Column
End With

' above better than (imo)
' nCol = ws.Cells.SpecialCells(xlCellTypeLastCell).Column + 1

If nCol ws.Columns.Count Then
' bit more work to do
' must be an empty column somwhere ???
End If

With rData(1)
'somthing like =COUNTIF($A$2:A2,A2)1
sFmla = "=COUNTIF(" & .Address & ":" & .Address(0, 0) _
& "," & .Address(0, 0) & ")1"
Set rTmp = ws.Cells(.Row, nCol)
bTopRow = (.Rows(1).Row = 1)
End With

rTmp.Formula = sFmla
rTmp.AutoFill Destination:=Range(rTmp, ws.Cells(lLast, nCol))

If Application.Calculation < xlCalculationAutomatic Then
ws.Calculate
End If

If bTopRow Then
Rows("1:1").Insert
End If

rTmp.Offset(-1, 0) = "abc"

On Error Resume Next
Do While nFcnt = 0
rTmp.Offset(-1, 0).AutoFilter
nFcnt = ws.AutoFilter.Filters.Count
Loop

rTmp.Offset(-1, 0).AutoFilter Field:=nFcnt, Criteria1:="TRUE"

rData.EntireRow.Delete
rTmp.AutoFilter
rTmp.Columns(1).EntireColumn.Delete

If bTopRow Then
Rows("1:1").EntireRow.Delete
End If
End Sub

Sub MakeDups()
Dim nRows As Long, i As Long

'Columns("A:A").ClearContents

nRows = 1000
ReDim arr(1 To nRows, 1 To 1)

For i = 1 To nRows
arr(i, 1) = "Hello " & Format(Int((100) * Rnd), "00")
Next
Range("a2:a" & nRows).Value = arr

End Sub

Regards,
Peter T

"Peter T" <peter_t@discussions wrote in message
...
Hi Bart,

Have you thought of adding a helper column with formula (this assumes
looking for duplicates in A2 down) -

=COUNTIF($A$2:A2,A2)1

Use "autofill" to copy down to the last row
Add an Auto filter top of this column, filter True and delete entire rows
of
the filter range.
Could use the hidden sheet name "_Filterdatabase" (starting one row down
from the top if necessary).

Regards,
Peter T

"RB Smissaert" wrote in message
...
Jim,

A bit neater again, but maybe it has to be done the messy way as I
noticed
objects in the sheet are lost.
Although it is a lot more code, maybe there are advantages to do this
without the filter altogether.
So get the range in an array, filter the unique rows in the array and
put
it
back.
The one advantage I can see is that you do it case sensitive and case
in-sensitive.
The drawback would be it that if the range is large it might get a bit
slow.

RBS



"Jim Cone" wrote in message
...
RBS,

I did play around with using only the original sheet.
However, it involved...
Using SpecialCells to get the visible range.
Looping thru each range area and writing each cell value to an
array.
Placing the array on the sheet.
It wasn't very neat.

The following is an amended version of my earlier post that
is a little more compact...
Regards,
Jim Cone
San Francisco, USA

'---------------------------
Sub test()
FilterUniqueInRange ActiveSheet, ActiveWindow.RangeSelection
End Sub
'---
Sub FilterUniqueInRange(sh As Worksheet, rng As Range)
Dim strName As String
Dim shtTemp

strName = sh.Name
Set shtTemp = _
ActiveWorkbook.Sheets.Add(after:=Worksheets(strNam e), Count:=1)
sh.Activate
rng.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=shtTemp.Range(rng(1).Address), Unique:=True

Application.DisplayAlerts = False
sh.Delete
shtTemp.Name = strName
Application.DisplayAlerts = True
Set shtTemp = Nothing
End Sub
'---------------------------


"RB Smissaert"

wrote in message

Jim,
Yes, that is a bit neater indeed.
I was hoping though that there might be a way to do away
with the temp worksheet, although it is not really a problem.
RBS