Appending, sorting and removing duplicates of chunks of data per column

[terryhenderson]

Hi Guys,

I have two worksheets:

Sheet1 which has one column ColA, that contains unfixed number of chunks of data all separated with one empty row.
Sheet2 which has one column ColA that contains fixed number of data at 32 each, and also all separated with one empty row.

What I am after is to:

1. append each group of data from Sheet1 ColA, with its equivalent group of data in Sheet2 ColA, so that the first group of data in Sheet1 ColA goes with the first group of data in Sheet2 ColA, and so on, then
2. sort ascend each group, and remove duplicates if there's any.

If a group in Sheet2 does not have an equivalent group in Sheet1, then it is sorted and had any duplicates removed as there's nothing to append from Sheet1.

The final outcome is expected to be in Sheet3 ColA, as shown in the attached example.

Can I get assistance with this question, please?

Many thanks in advance.

List_of_names_appending_sorting.xlsx

[Greg M]

Hi there,

If all of the names are to be combined as shown in Sheet 3, can what you want be achieved by just combining all of the names from Sheets 1 and 2 into a single list, sorting them, and then removing any duplicates?

Regards,

Greg M

[terryhenderson]

Thank you very much Greg M for your response. In fact, the reason behind segmenting data into groups it that every group has its individual properties. In my real data, they are not names, but components of different entities.
All the best.

[jindon]

This should do

Sub test()
    Dim myAreas1 As Areas, myAreas2 As Areas, i As Long, LastR As Range, flg As Boolean
    On Error Resume Next
    Set myAreas1 = Sheets("sheet1").Columns(1).SpecialCells(2).Areas
    Set myAreas2 = Sheets("sheet2").Columns(1).SpecialCells(2).Areas
    On Error GoTo 0
    If (myAreas1 Is Nothing) + (myAreas2 Is Nothing) Then Exit Sub
    For i = 1 To Application.Max(myAreas1.Count, myAreas2.Count)
        Set LastR = Sheets("sheet3").Cells(1): flg = False
        If Not IsEmpty(LastR) Then
            Set LastR = Sheets("sheet3").Range("a" & Rows.Count).End(xlUp)(3)
        End If
        If i <= myAreas1.Count Then myAreas1(i).Copy LastR: flg = True
        If i <= myAreas2.Count Then myAreas2(i).Copy IIf(flg, _
            Sheets("sheet3").Range("a" & Rows.Count).End(xlUp)(2), LastR)
        With LastR.CurrentRegion
            .Sort .Cells(1), 1
            .RemoveDuplicates 1, 2
        End With
    Next
End Sub

[terryhenderson]

Thank you very much Jindon for such masterpiece. Words are incapable to express my gratitude.
I ran the code it did exactly what is needed.
All the best my dear.

[jindon]

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED.

[Kaper]

Hi, I wrote also simple code (not that elegant as jindon's piece), but it took me some time to test it (had some problems with diffrent number of chunks.

Anyway, it is ready so I'll publish it too:

Sub test()
Dim pos1 As Long, pos2 As Long, pos3 As Long, end1 As Long, end2 As Long, end3 As Long
pos1 = 1: pos2 = 1: pos3 = 1
Application.ScreenUpdating = False
Do
  end1 = Sheets("Sheet1").Cells(pos1, "A").End(xlDown).Row
  end2 = Sheets("Sheet2").Cells(pos2, "A").End(xlDown).Row
  With Sheets("Sheet1")
    If end1 < Rows.Count Then Range(.Cells(pos1, "A"), .Cells(end1, "A")).Copy Sheets("Sheet3").Cells(pos3, "A")
  End With
  With Sheets("Sheet2")
    end3 = Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Row + 2
    If end2 < Rows.Count Then Range(.Cells(pos2, "A"), .Cells(end2, "A")).Copy Sheets("Sheet3").Cells(end3, "A")
  End With
  With Sheets("Sheet3")
    end3 = .Cells(Rows.Count, "A").End(xlUp).Row
    Range(.Cells(pos3, "A"), .Cells(end3, "A")).Sort key1:=.Cells(pos3, "A"), order1:=xlAscending, Header:=xlNo
    Range(.Cells(pos3, "A"), .Cells(end3, "A")).RemoveDuplicates Columns:=1, Header:=xlNo
    pos3 = .Cells(Rows.Count, "A").End(xlUp).Row + 2
  End With
  If end1 < Rows.Count Then pos1 = end1 + 2
  If end2 < Rows.Count Then pos2 = end2 + 2
Loop Until end2 = Rows.Count And end1 = Rows.Count
End Sub

[Kaper]

Hi, I wrote also simple code (not that elegant as jindon's piece), but it took me some time to test it (had some problems with diffrent number of chunks.

Anyway, it is ready so I'll publish it too:

Sub test()
Dim pos1 As Long, pos2 As Long, pos3 As Long, end1 As Long, end2 As Long, end3 As Long
pos1 = 1: pos2 = 1: pos3 = 1
Application.ScreenUpdating = False
Do
  end1 = Sheets("Sheet1").Cells(pos1, "A").End(xlDown).Row
  end2 = Sheets("Sheet2").Cells(pos2, "A").End(xlDown).Row
  With Sheets("Sheet1")
    If end1 < Rows.Count Then Range(.Cells(pos1, "A"), .Cells(end1, "A")).Copy Sheets("Sheet3").Cells(pos3, "A")
  End With
  With Sheets("Sheet2")
    end3 = Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Row + 2
    If end2 < Rows.Count Then Range(.Cells(pos2, "A"), .Cells(end2, "A")).Copy Sheets("Sheet3").Cells(end3, "A")
  End With
  With Sheets("Sheet3")
    end3 = .Cells(Rows.Count, "A").End(xlUp).Row
    Range(.Cells(pos3, "A"), .Cells(end3, "A")).Sort key1:=.Cells(pos3, "A"), order1:=xlAscending, Header:=xlNo
    Range(.Cells(pos3, "A"), .Cells(end3, "A")).RemoveDuplicates Columns:=1, Header:=xlNo
    pos3 = .Cells(Rows.Count, "A").End(xlUp).Row + 2
  End With
  If end1 < Rows.Count Then pos1 = end1 + 2
  If end2 < Rows.Count Then pos2 = end2 + 2
Loop Until end2 = Rows.Count And end1 = Rows.Count
End Sub

[terryhenderson]

Thank you very much Kaper for your magic code. I also tested it and it did run smoothly and produced the desired result.
Now I have two masterpieces in hand for the same question.
Once again thank you.
Best regards,