Solved: Strange find non duplicates

cdkeito

Board Regular
Joined
Aug 26, 2005
Messages
95
I've written some code:

Code:
Sub DeleteNoDplARP()
    Application.ScreenUpdating = False
    Dim k As Integer
    Dim r As Range
    Dim f As Range
    Dim riga As String
        
    k = Sheets("Report Presenze").Range("d65536").End(xlUp).Row
    Columns("E").Insert shift:=xlToRight
    For Each r In Sheets("Report Presenze").Range("a10:a" & k)
        If r.Offset(, 2) <> "" Then
            r.Offset(, 4).Formula = "=countif(c$10:c$" & k & ",c" & r.Row & ")"
        End If
    Next
    Range("e10:e" & k).Select
    'Columns("e").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, operation:=xlNone, skipblanks:=False, Transpose:=False
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    riga = ""
    For Each r In Sheets("Report Presenze").Range("a10:a" & k)
        If r.Offset(, 2) <> "" And riga <> "" Then
            Range(riga).EntireRow.Delete
            riga = ""
        End If
        If r.Offset(, 2) <> "" And r.Offset(, 4) = 1 And riga = "" Then
            riga = r.Address(0, 0)
        End If
        If r.Offset(, 2) = "" And riga <> "" Then
            riga = riga & "," & r.Address(0, 0)
        End If
    Next    '''''''''''''''''''''''''''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    Range(riga).EntireRow.Delete
    Columns("E").Delete shift:=xlToLeft
    
    k = Sheets("Report Presenze").Range("d65536").End(xlUp).Row
    For Each r In Sheets("Report Presenze").Range("a10:a" & k)
        If r.Value = "" Then r.FormulaR1C1 = "=R[-1]C"
        If r.Offset(, 1).Value = "" Then r.Offset(, 1).FormulaR1C1 = "=R[-1]C"
        'If r.Offset(, 2).Value = "" Then r.Offset(, 2).FormulaR1C1 = "=R[-1]C"
    Next
    'Range("A10:AQ" & k).Sort Key1:=Range("B10"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    Application.ScreenUpdating = True
End Sub
some hope?
 

cdkeito

Board Regular
Joined
Aug 26, 2005
Messages
95
now I've momentarily changed the
... .delete
to
... .interior.color = vbred

and added after "Columns("E").Delete shift:=xlToLeft "

an

for i=k to 10 step=-1
if cells(i,1).interior.color = vbred then rows(i).delete
next i

but this it does 3 swings of the sheet (normaly 400 rows, 300-400 sheets)

so its SLOOOOOOOOOOOOOOOW!

感謝
 

Aladin Akyurek

MrExcel MVP
Joined
Feb 14, 2002
Messages
85,138
cdkeito said:
...

In this example, you see, b1 and b10 are the same. I need to delete rows 3 :9;13:15.

I've writen something that use countif (on rows 1,3,7,10,13,14) and a later scan that analyze the results, storing the rows' number to delete (countif = 1); but, probably, you've a better idea.

Grazie!
UniqueRecs.xls
ABCDEFGHIJKLM
10
2X-1X-2X-3X-4X-5IdxPosX-1X-2X-3X-4X-5
3dfdsfa1sdsdsd
41fdsffdsf
5fdfsb2dfdsfjghj
62gfdggfdgfd
72gdffgdf
82utyukhjk
9hgfhc9fdjhgjyjn
Sheet1


F1 must house a 0.

F3, copied down:

=IF(B3<>"",IF(((ISNUMBER(MATCH(B3,B4:$B$17,0))+ISNUMBER(MATCH(B3,$B$2:B2,0)))>0),LOOKUP(9.99999999999999E+307,$F$1:F2)+1,""),IF((B3="")*ISNUMBER(F2)*(F2>0),F2+1,""))

H1:

=LOOKUP(9.999999999999E+307,F1:F17)

H3, copied down:

=IF(ROW()-ROW($H$3)+1<=$H$1,MATCH(ROW()-ROW($H$3)+1,$F$3:$F$17,1),"")

I3, copied across to J2 then copied down:

=IF(N($H3),IF(INDEX(A$3:A$17,$H3)="","",INDEX(A$3:A$17,$H3)),"")

K3, copied across to M3 then down:

=IF(N($H3),INDEX(C$3:C$17,$H3),"")
 

cdkeito

Board Regular
Joined
Aug 26, 2005
Messages
95
OH, thanks!!!!!!!!!!
great formulas!!!!!

Now I'have only to make a vba that'll do this work on all sheets.
(very simple).

After that i'll put on a race: my baka macro Vs yours
 

Forum statistics

Threads
1,081,513
Messages
5,359,226
Members
400,521
Latest member
smarty1995

Some videos you may like

This Week's Hot Topics

  • VBA (Userform)
    Hi All, I just would like to know why my code isn't working. Here is my VBA code: [CODE=vba]Private Sub OKButton_Click() Dim i As Integer...
  • List box that changes fill color
    Hello, I have gone through so many pages trying to figure this out. I have a 2020 calendar that depending on the day needs to have a certain...
  • Remove duplicates and retain one. Cross-linked cases
    Hi all I ran out of google keywords to use and still couldn't find a reference how to achieve the results of a single count. It would be great if...
  • VBA Copy and Paste With Duplicates
    Hello All, I'm in need of some input. My VBA skills are sub-par at best. I've assembled this code from basic research and it works but is...
  • Macro
    is it possible for a macro to run if the active cell value is different to the value above it
  • IF DATE and TIME
    I currently use this to check if date has passed but i also need to set a time on it too. Is it possible? [CODE=vba]=IF(B:B>TODAY(),"Not...
Top