VBA Extract unique values in multiple sheets

[rplohocky]

Hello,
I found this awesome code that extracts unique values found in column A in every sheet, creates a new sheet, pastes them into column A and then alphabetizes them.

Sub UniqueValues()
Dim newWS As Worksheet, r As Long, N As Long, i As Integer
Application.ScreenUpdating = False
For Each ws In Sheets

Application.DisplayAlerts = False
If ws.Name = "UNIQUE_DATA" Then ws.Delete
Application.DisplayAlerts = True

Next
Set newWS = Sheets.Add(after:=Sheets(Sheets.Count))
newWS.Name = "UNIQUE_DATA"
N = 1
For i = 1 To Sheets.Count - 1
r = Sheets(i).Cells(Rows.Count, "A").End(xlUp).Row
Sheets(i).Range("A3:A" & r).Copy
Cells(N, 1).PasteSpecial xlValues
N = Cells(Rows.Count, "A").End(xlUp).Row + 1

Next
r = Cells(Rows.Count, "A").End(xlUp).Row
Range("A3:A" & r).AdvancedFilter _
Action:=xlFilterInPlace, Unique:=True
Range("A3:A" & r).Copy
Range("B1").PasteSpecial xlValues
Application.CutCopyMode = False

Range("A3:A" & r).AdvancedFilter _
Action:=xlFilterInPlace, Unique:=False
Columns(1).Delete
r = Cells(Rows.Count, "A").End(xlUp).Row

'Below sorts the data alphabeticaly.
Range("A1:A" & r).Sort key1:=Range("A1"), Header:=xlNo
Application.ScreenUpdating = True

End Sub

I was wondering what I need to change so it will look in A3 through the rest of column A. My header row is in row 2 and my data starts in row 3. The issue now is the macro grabs row 2 as well. I changed the range where i thought it should be changes to A3:A but nothing I do seems to have any affect.

 

[wideboydixon]

Try it like this (untested):

Sub UniqueValues()

Dim ws As Worksheet, newWS As Worksheet, r As Long, N As Long, i As Integer
Application.ScreenUpdating = False

For Each ws In Sheets
    Application.DisplayAlerts = False
    If ws.Name = "UNIQUE_DATA" Then ws.Delete
    Application.DisplayAlerts = True
Next

Set newWS = Sheets.Add(after:=Sheets(Sheets.Count))
newWS.Name = "UNIQUE_DATA"

N = 1
For i = 1 To Sheets.Count - 1
    r = Sheets(i).Cells(Rows.Count, "A").End(xlUp).Row
    Sheets(i).Range("A3:A" & r).Copy
    Cells(N, 1).PasteSpecial xlValues
    N = Cells(Rows.Count, "A").End(xlUp).Row + 1
Next

r = Cells(Rows.Count, "A").End(xlUp).Row
Range("A1:A" & r).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Range("A1:A" & r).Copy
Range("B1").PasteSpecial xlValues
Application.CutCopyMode = False

Range("A1:A" & r).AdvancedFilter Action:=xlFilterInPlace, Unique:=False
Columns(1).Delete

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

'Below sorts the data alphabeticaly.
Range("A1:A" & r).Sort key1:=Range("A1"), Header:=xlNo
Application.ScreenUpdating = True

End Sub

WBD

 

[rplohocky]

Try it like this (untested):

Sub UniqueValues()

Dim ws As Worksheet, newWS As Worksheet, r As Long, N As Long, i As Integer
Application.ScreenUpdating = False

For Each ws In Sheets
    Application.DisplayAlerts = False
    If ws.Name = "UNIQUE_DATA" Then ws.Delete
    Application.DisplayAlerts = True
Next

Set newWS = Sheets.Add(after:=Sheets(Sheets.Count))
newWS.Name = "UNIQUE_DATA"

N = 1
For i = 1 To Sheets.Count - 1
    r = Sheets(i).Cells(Rows.Count, "A").End(xlUp).Row
    Sheets(i).Range("A3:A" & r).Copy
    Cells(N, 1).PasteSpecial xlValues
    N = Cells(Rows.Count, "A").End(xlUp).Row + 1
Next

r = Cells(Rows.Count, "A").End(xlUp).Row
Range("A1:A" & r).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Range("A1:A" & r).Copy
Range("B1").PasteSpecial xlValues
Application.CutCopyMode = False

Range("A1:A" & r).AdvancedFilter Action:=xlFilterInPlace, Unique:=False
Columns(1).Delete

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

'Below sorts the data alphabeticaly.
Range("A1:A" & r).Sort key1:=Range("A1"), Header:=xlNo
Application.ScreenUpdating = True

End Sub

WBD

I found the code this way which is why I changed the A1:A to A3:A thinking it would only look at A3 and down but it still grabs the entire column including the header row. Any other ideas?

 

[wideboydixon]

It grabs A3 down on the data sheets but then has to remove duplicates / sort the entire column on the new sheet.

WBD