Re-arranging and Sorting Data using a VBA Macro

[clarkmarka]

Hello Mr. Excel Forum,
I am constantly working with data that is presented in 4 columns. Please see below.

For my non profit, we create reports that are arranged such that the Memorial Name appears first, followed by the Constituents that contributed in honor of that person. However, the catch is that both fields (Memorial - Parent) and (Constituent - Child) are arranged in ABC order by Last Name. It should look like this.

I am hoping to have a macro that I can apply to data after downloading in this 4 column format that presents in this way, sorting each level of data by last name.
Any advice would be really appreciated. I've tried a number of macros I've found on this and other forums but nothing has worked.

Mark

 

[Akuini]

@clarkmarka, welcome to the Forum.
Could you copy-paste the example here? so we don't need to retype it.

 

[clarkmarka]

Book1
	A	B	C	D	E	F	G
1	Memorial	mLast_Name	Constituent	cLast_Name		Randal Avery
2	Pauline Smith	Smith	Vicki Newton	Newton			Tracy Lilly
3	Pauline Smith	Smith	Tracy Lilly	Lilly			Marcus Smith
4	Randal Avery	Avery	Tracy Lilly	Lilly
5	Randal Avery	Avery	Macus Smith	Smith		Richard Blake
6	Richard Blake	Blake	Macus Smith	Smith			Paul Elias
7	Richard Blake	Blake	Tracy Lilly	Lilly			Tracy Lilly
8	Richard Blake	Blake	Vicki Newton	Newton			Vicki Newton
9	Richard Blake	Blake	Paul Elias	Elias			Marcus Smith
10
11						Pauline Smith
12							Tracy Lilly
13							Vicki Newton
Sheet1

 

[clarkmarka]

I hope I pasted this correctly. I was intending for the results to display on a separate sheet, but wasn't sure how to show that.

 

[Akuini]

Try this:

Sub clarkmarka()
Dim i As Long, j As Long, k As Long, n As Long
Dim va, vb, vx
n = Range("A" & Rows.Count).End(xlUp).Row
vx = Range("A2:D" & n)
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("B1"), Order:=xlAscending
        .SortFields.Add Key:=Range("A1"), Order:=xlAscending
        .SortFields.Add Key:=Range("D1"), Order:=xlAscending
        .SortFields.Add Key:=Range("C1"), Order:=xlAscending
        .SetRange Range("A1:D" & n)
        .Header = xlYes
        .Apply
    End With

'data start at row 2
va = Range("A2:C" & n + 1) 'n + 1 because I need to add 1 blank cell, otherwise if last cell is unique then
                           'the last i will get "Subscript out of range" on va(i + 1, 1)

ReDim vb(1 To UBound(va, 1) * 2, 1 To 2)

For i = 1 To UBound(va, 1) - 1
    j = i
    Do While va(i, 1) = va(i + 1, 1)
        i = i + 1
    Loop
    
    k = k + 1
    vb(k, 1) = va(j, 1)
    For x = j To i
        k = k + 1
        vb(k, 2) = va(x, 3)
    Next
Next
'put the result in F2
Range("F2").Resize(k, 2) = vb
Range("A2:D" & n) = vx
End Sub

 

[clarkmarka]

This looks great. What would I need to do if I wanted to make two changes to this.
1. Add a space before every new entry in the first column.

2. Present the data on a separate sheet. I imagine I would involve something with the range in the last step.

Thank you for all your advice so far. This is very helpful and I'm beginning to understand how it works.

Mark

 

[Akuini]

Try this one:

Sub clarkmarka_2()
Dim i As Long, j As Long, k As Long, n As Long
Dim va, vb, vx
n = Range("A" & Rows.Count).End(xlUp).Row
vx = Range("A2:D" & n)
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("B1"), Order:=xlAscending
        .SortFields.Add Key:=Range("A1"), Order:=xlAscending
        .SortFields.Add Key:=Range("D1"), Order:=xlAscending
        .SortFields.Add Key:=Range("C1"), Order:=xlAscending
        .SetRange Range("A1:D" & n)
        .Header = xlYes
        .Apply
    End With


'data start at row 2
va = Range("A2:C" & n + 1) 'n + 1 because I need to add 1 blank cell, otherwise if last cell is unique then
                           'the last i will get "Subscript out of range" on va(i + 1, 1)

ReDim vb(1 To UBound(va, 1) * 2, 1 To 2)

For i = 1 To UBound(va, 1) - 1
    j = i
    Do While va(i, 1) = va(i + 1, 1)
        i = i + 1
    Loop
   
    k = k + 1
    vb(k, 1) = va(j, 1)
    For x = j To i
        k = k + 1
        vb(k, 2) = va(x, 3)
    Next
    k = k + 1
Next

Range("A2:D" & n) = vx

'put the result in sheet2
Sheets("Sheet2").Range("A2").Resize(k, 2) = vb

End Sub

 

[clarkmarka]

Hi - The spacing is working perfectly. However, when I try to put into Sheet 2, it simply doesn't run.
Do I need to add something custom to the code?

'put the result in sheet2
Sheets("Sheet2").Range("A2").Resize(k, 2) = vb

End Sub

 

[Akuini]

The sheet's name should be "Sheet2" not "Sheet 2"

 

[clarkmarka]

Thank you! It works now.