VBA Run Time Error 1004 Advanced Filter

[Lewzerrrr]

Hey,

It's not that much of a problem as the rarity of it happening is very slim BUT one that I would like to eradicate JUST in case as it stops my worksheet_change.

I'm using the following code to extract unique values from a list in A2:A & Last Row.. if I was to only add in 1 or 2 values to the list then I get the following error and it crashes the code. How can I prevent this?

Sub UniqueCopy()

Dim sht As Worksheet
Dim lr As Long, lrc As Long


Set sht = ActiveWorkbook.Sheets(1)


Application.EnableEvents = False
Application.ScreenUpdating = False


sht.Range("I2:I1000").ClearContents


lr = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row


If sht.Range("A2") = "" Then
    'do nothing
Else
[B]    sht.Range("A2:A" & lr).AdvancedFilter Action:=xlFilterCopy, copytorange:=sht.Range("I2"), unique:=True[/B]
End If


lrc = sht.Cells(sht.Rows.Count, "I").End(xlUp).Row


If sht.Range("A2") = "" Then
    'do nothing
Else
    sht.Range("I2:I" & lrc).Copy
End If


Application.EnableEvents = True
Application.ScreenUpdating = True




End Sub

ALSO, on the slim chance of having some duplicates, sometimes it would pull 1 duplicate for example..

Notice how there is 2 3's?

	A	B
1	Header1	Header2
2	3	3
3	4	4
4	5	5
5	3	3
6	3	2
7	2	1
8	5
9	5
10	3
11	5
12	4
13	1
14	2
15	4
16	5
17	3
18	5
19	2
20	5
21	3
22	4
23	4
24	5

<tbody>
</tbody>

 

[mrhstn]

A stab in the dark here as I don't have Excel open but if it only happens when you add 1 or 2 values to your list then it could be you're filtering too few rows (given your lr variable is a count of rows in column A and you then filter from A2 to that last row)

Try adding something to lr in order to take into consideration the difference between lr and where you start...

lr = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 2

 

[hiker95]

Lewzerrrr,

Here is another macro solution for you to consider.

With your raw data in the Active Worksheet, column A, beginning in cell A2, the results will be written to column B, beginning in cell B2.


Try the following macro code.

Sub GetUniques()
' hiker95, 07/05/2017, ME1017639
Dim rng As Range, r As Range, o
With ActiveSheet
  Set rng = .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
  With CreateObject("Scripting.Dictionary")
    For Each r In rng
      If r <> "" Then
        If Not .Exists(r.Value) Then
          .Add r.Value, r.Value
        End If
      End If
    Next r
    o = Application.Transpose(Array(.Keys))
  End With
  .Range("B2").Resize(UBound(o)) = o
End With
End Sub

 

[Lewzerrrr]

A stab in the dark here as I don't have Excel open but if it only happens when you add 1 or 2 values to your list then it could be you're filtering too few rows (given your lr variable is a count of rows in column A and you then filter from A2 to that last row)

Try adding something to lr in order to take into consideration the difference between lr and where you start...

lr = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 2

Thanks, I think I understand, I managed to fix it with this
Can't seem to get rid of the duplicate value though, if the value of A2 is duplicated then it will only duplicate that, the rest are fine though!

On Error GoTo continue        
        If sht.Range("A2") = "" Then
            'do nothing
        Else
            sht.Range("A2:A" & lr).AdvancedFilter Action:=xlFilterCopy, copytorange:=sht.Range("I2"), unique:=True
        End If
        
continue:
            If Len(Range("A2")) = 1 Then
                sht.Range("A2").Copy sht.Range("I2")
            Else
                'do nothing
            End If

 

[Lewzerrrr]

Lewzerrrr,

Here is another macro solution for you to consider.

With your raw data in the Active Worksheet, column A, beginning in cell A2, the results will be written to column B, beginning in cell B2.


Try the following macro code.

Sub GetUniques()
' hiker95, 07/05/2017, ME1017639
Dim rng As Range, r As Range, o
With ActiveSheet
  Set rng = .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
  With CreateObject("Scripting.Dictionary")
    For Each r In rng
      If r <> "" Then
        If Not .Exists(r.Value) Then
          .Add r.Value, r.Value
        End If
      End If
    Next r
    o = Application.Transpose(Array(.Keys))
  End With
  .Range("B2").Resize(UBound(o)) = o
End With
End Sub

Thanks Hiker! Really appreciating all your help recently!

 

[hiker95]

Thanks Hiker! Really appreciating all your help recently!

Lewzerrrr,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.