Copying from one worksheet to another with added complications

[rnewton]

Ok, I am trying to figure out a way to move records from one worksheet to another, my biggest problem is: Each row in the source worksheet can have up to 3 records, and those records have identical column header titles. I also only want to pull certain columns over to new worksheet. Here's how that looks: (there are many columns in source, this is just an example)

[TABLE="class: outer_border, width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Address[/TD]
[TD]Title[/TD]
[TD]Phone[/TD]
[TD]Name[/TD]
[TD]Address[/TD]
[TD]Title[/TD]
[TD]Phone[/TD]
[TD]Name[/TD]
[TD]Address[/TD]
[TD]Title[/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD]John[/TD]
[TD]123 Main st[/TD]
[TD]Mr.[/TD]
[TD]555-5555[/TD]
[TD]Sally[/TD]
[TD]222 something rd[/TD]
[TD]Ms.[/TD]
[TD][/TD]
[TD]Eric[/TD]
[TD]333 Adress pl[/TD]
[TD][/TD]
[TD]555-1234[/TD]
[/TR]
[TR]
[TD]Bill[/TD]
[TD][/TD]
[TD]Mr.[/TD]
[TD]111-1111[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Jill[/TD]
[TD]45 45th st[/TD]
[TD]Mrs.[/TD]
[TD]222-2222[/TD]
[TD]Sam[/TD]
[TD]88 8th st[/TD]
[TD]Mr.[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

The destination spreadsheet already has desired header titles in place, and would like to have only 1 record per row. For example:

[TABLE="class: outer_border, width: 500"]
<tbody>[TR]
[TD]Title[/TD]
[TD]Name[/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD]Mr.[/TD]
[TD]John[/TD]
[TD]555-5555[/TD]
[/TR]
[TR]
[TD]Ms.[/TD]
[TD]Sally[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Eric[/TD]
[TD]555-1234[/TD]
[/TR]
[TR]
[TD]Mr.[/TD]
[TD]Bill[/TD]
[TD]111-1111[/TD]
[/TR]
[TR]
[TD]Mrs.[/TD]
[TD]Jill[/TD]
[TD]222-2222[/TD]
[/TR]
[TR]
[TD]Mr.[/TD]
[TD]Sam[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


How would we keep the data from crossing over or overwriting records? What I have so far:

I've declared the following:
Source Worksheet = sWS
Destination Worksheet = dWS
Source Headers = sHDR
Destination Headers = dHDR
Source Rows = sRWS

UPDATE!

Through the process of trying to thoroughly explain this problem, I was able to solve this myself. I put too much effort into this to delete, so here's what I did:

i = 1
a = 2

Dim MATCH As Range


For Each RW In sRWS
    For i = 1 To sHDR.Columns.Count
        Set MATCH = dHDR.Find(what:=sWS.Cells(1, i).Value, lookat:=xlWhole)
            If Not MATCH Is Nothing Then
Step1:
                    If IsEmpty(dWS.Cells(a, MATCH.Column).Value) = True Then
                        dWS.Cells(a, MATCH.Column) = sWS.Cells(RW.Row, i).Value
                    Else
                        a = a + 1
                        GoTo Step1
                    End If
            End If
    Next i
Next RW

Any pointers on making this more efficient would be appreciated, but it functions....

Thanks all!