Merge 2 columns and remove duplicates

[production123]

Hi, i’ve started using VBA at my work and have stumbled on what seems like a very simple problem, but I am unable to see any answers that suit my needs on here.

Basically, I have Column A on sheet 1, and Column A on sheet2, and they have about 30,000 rows on each. I want to copy and paste, as values, both columns into Sheet3, and remove duplicates. Currently i have VBA doing this but it’s an unedited, recorded macro and takes 3 mins for it to work.

Is there a faster way of doing this?

 

[Fluff]

Hi & welcome to MrExcel.
As it's a recorded macro the answer is yes
Although with general questions like this, it normally helps if you supply the code your using

 

[Fluff]

Depending how many unique values you have try

Sub production123()
   Dim Cl As Range
   Dim Ws1 As Worksheet, Ws2 As Worksheet
   
   Set Ws1 = Sheets("Sheet1")
   Set Ws2 = Sheets("Sheet2")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws1.Range("A2", Ws1.Range("A" & Rows.Count).End(xlUp))
         .Item(Cl.Value) = Empty
      Next Cl
      For Each Cl In Ws2.Range("A2", Ws2.Range("A" & Rows.Count).End(xlUp))
         .Item(Cl.Value) = Empty
      Next Cl
      Sheets("Sheet3").Range("A2").Resize(.Count).Value = Application.Transpose(.Keys)
   End With
End Sub

 

[production123]

Thanks - I have managed to simplify it down to the below - on sheet3 I have columns B-Q which have formula that look up other contents in sheet1 and 2 which works fine.

Columns A on both sheets is a formula which creates a unique identifer from different formats. The most data I have seen in one tab is 27855, it varies every day which is why I have dragged the formula down to row30000 to make sure.

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False

'
' Position_rec Macro
'

'
Sheets("Sheet1").Range("A2:A30000").Copy
Sheets("Sheet3").Range("A2").PasteSpecial xlPasteValues

Sheets("Sheet2").Range("A2:A30000").Copy
Sheets("Sheet3").Range("A30002").PasteSpecial xlPasteValues

Columns("A:Q").Select
ActiveSheet.Range("$A:$Q").RemoveDuplicates Columns:=1, Header:=xlNo

Sheets("Sheet3").Range("$A$1:$Q$60003").AutoFilter Field:=11, Criteria1:="<>0", _
Operator:=xlAnd

Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True

End Sub

 

[production123]

Depending how many unique values you have try

Sub production123()
   Dim Cl As Range
   Dim Ws1 As Worksheet, Ws2 As Worksheet
   
   Set Ws1 = Sheets("Sheet1")
   Set Ws2 = Sheets("Sheet2")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws1.Range("A2", Ws1.Range("A" & Rows.Count).End(xlUp))
         .Item(Cl.Value) = Empty
      Next Cl
      For Each Cl In Ws2.Range("A2", Ws2.Range("A" & Rows.Count).End(xlUp))
         .Item(Cl.Value) = Empty
      Next Cl
      Sheets("Sheet3").Range("A2").Resize(.Count).Value = Application.Transpose(.Keys)
   End With
End Sub

Thank you, this works a lot faster than the current! My last message shows what I had, I have a filter on which removes 0s from column Q on sheet3 as well but I will add that in!

Great help thanks

 

[Fluff]

You're welcome & thanks for the feedback.