Combine data from multiple sheets and remove duplicates if any

I have data in multiple worksheets in specific columns.I want all of them to be in a two columns with no duplicates.Sample data and expected results are shown in Worksheet'Expected Result' in column A and B.

How about (Run "jec"):

Sub jec()
 Dim sh, ar, k, i As Long
 With CreateObject("scripting.dictionary")
   For Each sh In ThisWorkbook.Sheets
     If sh.Index > 1 Then
       ar = sh.Range("C6", sh.Range("C" & Rows.Count).End(xlUp))
       For i = 1 To UBound(ar)
          k = getNum(ar(i, 1))
         .Item(k) = Array(k, ar(i, 1))
       Next
     End If
   Next
  Sheets("Expected Result").Range("A2").Resize(.Count, 2) = Application.Index(.items, 0, 0)
 End With
End Sub


Function getNum(cell As Variant) As Variant
 With CreateObject("vbscript.regexp")
   .Global = True
   .Pattern = "\d{9}"
    If .test(cell) Then
      getNum = .Execute(cell)(0)
    Else
      getNum = cell
    End If
 End With
End Function

Originally Posted by JEC.

How about (Run "jec"):

Sub jec()
 Dim sh, ar, k, i As Long
 With CreateObject("scripting.dictionary")
   For Each sh In ThisWorkbook.Sheets
     If sh.Index > 1 Then
       ar = sh.Range("C6", sh.Range("C" & Rows.Count).End(xlUp))
       For i = 1 To UBound(ar)
          k = getNum(ar(i, 1))
         .Item(k) = Array(k, ar(i, 1))
       Next
     End If
   Next
  Sheets("Expected Result").Range("A2").Resize(.Count, 2) = Application.Index(.items, 0, 0)
 End With
End Sub


Function getNum(cell As Variant) As Variant
 With CreateObject("vbscript.regexp")
   .Global = True
   .Pattern = "\d{9}"
    If .test(cell) Then
      getNum = .Execute(cell)(0)
    Else
      getNum = cell
    End If
 End With
End Function

Kindly add sheet name in code (As I will be combining specific sheet name and not all) with sorted alphabetically.

Hi. My ver

Sub Unify()
Dim ws As Integer, C As Range, D As Range
Application.ScreenUpdating = False
Range("A1").CurrentRegion.Offset(1).Delete xlShiftUp
Columns("C:G").Delete xlShiftUp

For ws = 1 + ActiveSheet.Index To Worksheets.Count
  With Worksheets(ws)
    .Range("C6", .Cells(Rows.Count, "C").End(xlUp)).Copy Cells(Rows.Count, "B").End(xlUp).Offset(1)
  End With
Next

With Range("B2", Range("B1").End(xlDown))
  .Replace What:=vbLf, Replacement:="", LookAt:=xlPart
  .TextToColumns Destination:=Range("C2"), DataType:=xlDelimited, Other:=True, OtherChar:="("
  Columns("C").Delete
  For Each C In .Offset(, 1)
    If C.Row > 1 Then
      Set D = C
      Do Until D = Empty
        If IsNumeric(Left(D, 9)) Then
          Cells(D.Row, "A") = 0 + Left(D, 9)
          Exit Do
        Else
          Set D = D.Offset(, 1)
        End If
      Loop
    End If
  Next
End With

Columns("C:G").Delete xlShiftUp
With Range("A1").CurrentRegion
  .Sort Range("A1"), 1, Key2:=Range("B1"), Order2:=1, Header:=xlYes
  Range("G2") = "=CountIf(" & .Address & ", A2)>1"
  .AdvancedFilter 2, Range("G1:G2"), Range("D1"), False
End With
Range("G2").Clear: Columns("A:E").AutoFit: Columns("A:E").VerticalAlignment = xlCenter
End Sub

Sub test()
    Dim ws As Worksheet, e, a, x, i As Long, ii As Long
    Application.ScreenUpdating = False
    Set ws = Sheets("expected result")
    ws.Columns("a:b").ClearContents
    ws.[a1:b1] = [{"Code","List"}]
    For Each e In Sheets(Array("L", "P", "A", "M"))  '<--- Add/remove if needed.
        With e.Range("c6", e.Range("c" & Rows.Count).End(xlUp))
            ws.Range("b" & Rows.Count).End(xlUp)(2).Resize(.Rows.Count).Value = .Value
        End With
    Next
    With ws.Range("b2", ws.Range("b" & Rows.Count).End(xlUp))
        .Replace vbLf, "", 2
        a = .Value
        For i = 1 To UBound(a, 1)
            x = Split(a(i, 1), "(")
            If UBound(x) > 0 Then
                For ii = 1 To UBound(x)
                    If Val(x(ii)) Like String(9, "#") Then
                        a(i, 1) = Val(x(ii)): Exit For
                    End If
                Next
            End If
        Next
        With .Columns(0).Resize(, 2)
            .Columns(1) = a
            .Sort .Columns(2)
            .RemoveDuplicates 1, 0
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Thanx @JEC & @jindongot the results as expected. Post #1 remaining part adding specific sheet name & sorting alphabetically was accomplished perfectly by Jindon.

Kindly enclosed the workbook with your code.My Last version of office is 2021.

Here my solution, including the sorting and predefined sheetnames.

Sub jec()
 Dim sh, d, ar, k, i As Long
 Set d = CreateObject("scripting.dictionary")
 
 For Each sh In Sheets(Array("L", "P", "A", "M"))
    ar = sh.Range("C6", sh.Range("C" & Rows.Count).End(xlUp))
    For i = 1 To UBound(ar)
       k = getNum(ar(i, 1))
       d(k) = Array(k, ar(i, 1))
    Next
 Next
 With Sheets("Expected Result").Range("A2").Resize(d.Count, 2)
   .CurrentRegion.Offset(1).ClearContents
   .Value = Application.Index(d.items, 0, 0)
   .Sort .Columns(2)
 End With
End Sub


Function getNum(cell As Variant) As Variant
 With CreateObject("vbscript.regexp")
   .Global = True
   .Pattern = "\d{9}"
    If .test(cell) Then
      getNum = .Execute(cell)(0)
    Else
      getNum = cell
    End If
 End With
End Function

Thanx JEC.

You're welcome!

And one with power query

let
    Source = Table.Combine({L, P, A, M}),
    AddColl = Table.AddColumn(Source, "Aangepast", each List.Transform(Text.ToList([Kolom1]),each if Value.Is(Value.FromText(_), type number) then _ else null)),
    outRes = Table.AddColumn(Table.TransformColumns(AddColl, {"Aangepast", each Text.Combine(List.Transform(_, Text.From)), type text}), "Aangepast.1", each if Text.Length([Aangepast]) >0 then [Aangepast] else [Kolom1]),
    outOrd = Table.Distinct(Table.ReorderColumns(Table.RemoveColumns(outRes,{"Aangepast"}),{"Aangepast.1", "Kolom1"}), {"Aangepast.1"})
in
    outOrd

Pls find enclosed in attachment.There is #Value Error in Column B in Consolidated Sheet on running code as per your Post #3.This was the main reason,why it did not worked in my version of excel.


Value error.png

Oh,Now I got it.Thanx for the clearing the confusion.

Hi@Jindon,

Refer to your Post #8 code,I found some data not mentioned above in Post #1 (enclosed in attachment) instead of extracting number is extracting whole text.

I have highlighted the with Red color.

Hence,I hope you can revised your code accordingly. Others things are fine.

Sub test()
    Dim ws As Worksheet, e, a, v, x, i As Long
    Application.ScreenUpdating = False
    Set ws = Sheets("expected result")
    ws.Columns("a:b").ClearContents
    ws.[a1:b1] = [{"Code","List"}]
    For Each e In Sheets(Array("L", "P", "A", "M"))  '<--- Add/remove if needed.
        With e.Range("c6", e.Range("c" & Rows.Count).End(xlUp))
            ws.Range("b" & Rows.Count).End(xlUp)(2).Resize(.Rows.Count).Value = .Value
        End With
    Next
    With ws.Range("b2", ws.Range("b" & Rows.Count).End(xlUp))
        .Replace vbCrLf, "", 2
        a = .Value
        For i = 1 To UBound(a, 1)
            x = Split(Replace(a(i, 1), ")", ""), "(")
            If UBound(x) > 0 Then
                For Each e In x
                    For Each v In Split(Replace(e, "-", ","), ",")
                        If Not Trim$(v) Like "*[!0-9]*" Then
                            a(i, 1) = Trim$(v): Exit For
                        End If
                    Next
                Next
            End If
        Next
        With .Columns(0).Resize(, 2)
            .Columns(1) = a
            .Sort .Columns(2)
            .RemoveDuplicates 1, 0
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Worked well but one of my data earlier was resulted in correct way but now resulted wrong using this code.Kindly see what is missing.

Is this the last one?

Don't ask one by one.

Yes,it's last one.I have tested in all my private file with large data.

Add one line in bold

    With ws.Range("b2", ws.Range("b" & Rows.Count).End(xlUp))
        .Replace vbCrLf, "", 2
        .Replace vbTab, "", 2
        a = .Value