List of Names: Extract Address like info into individual row list (eg. Husbands/Wives/Singles)

[legogeek]

I'm sure this has been asked before - if so please direct me.

I have Fields: LastName,FirstName,Spouse,Position,Spouse Position

It's a list that also includes people that are singles.

Just looking for direction how to keep my original list AND elsewhere to have a list that derives and splits each person and their position into their own row (ie. bringing in the LastName for the wife). I am open to VBA ideas. I am hoping that the original list can be updated which will automatically update this new list as well.

Take this
[TABLE="width: 500"]
<tbody>[TR]
[TD]LastName[/TD]
[TD]FirstName[/TD]
[TD]Spouse[/TD]
[TD]Position[/TD]
[TD]Spouse Position[/TD]
[/TR]
[TR]
[TD]FlintStone[/TD]
[TD]Fred[/TD]
[TD]Wilma[/TD]
[TD]Quarry Operator[/TD]
[TD]Home Manager[/TD]
[/TR]
[TR]
[TD]FlintStone[/TD]
[TD]Bambam[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Lightyear[/TD]
[TD]Buzz[/TD]
[TD][/TD]
[TD]Star Commander[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mouse[/TD]
[TD]Mickey[/TD]
[TD]Minnie[/TD]
[TD]Disney Ambassador[/TD]
[TD]Bow Distributor[/TD]
[/TR]
</tbody>[/TABLE]

To get this - that can continually update from the is list above.
[TABLE="width: 500"]
<tbody>[TR]
[TD]LastName[/TD]
[TD]FirstName[/TD]
[TD]Position[/TD]
[/TR]
[TR]
[TD]FlintStone[/TD]
[TD]Fred[/TD]
[TD]Quarry Operator[/TD]
[/TR]
[TR]
[TD]FlintStone[/TD]
[TD]Wilma[/TD]
[TD]Home Manager[/TD]
[/TR]
[TR]
[TD]FlintStone[/TD]
[TD]Bambam[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Lightyear[/TD]
[TD]Buzz[/TD]
[TD]Star Commander[/TD]
[/TR]
[TR]
[TD]Mouse[/TD]
[TD]Mickey[/TD]
[TD]Disney Ambassador[/TD]
[/TR]
[TR]
[TD]Mouse[/TD]
[TD]Minnie[/TD]
[TD]Bow Distributor[/TD]
[/TR]
</tbody>[/TABLE]

 

[DanteAmor]

Put the following code in the events of the destination sheet

Private Sub Worksheet_Activate()
  Dim sh1 As Worksheet, sh2 As Worksheet, i As Long, j As Long
  Application.ScreenUpdating = False
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  sh2.Rows("2:" & Rows.Count).Clear
  j = 2
  For i = 2 To sh1.Range("A" & Rows.Count).End(xlUp).Row
    sh2.Cells(j, "A") = sh1.Cells(i, "A")
    sh2.Cells(j, "B") = sh1.Cells(i, "B")
    sh2.Cells(j, "C") = sh1.Cells(i, "D")
    j = j + 1
    If sh1.Cells(i, "C") <> "" Then
      sh2.Cells(j, "A") = sh1.Cells(i, "A")
      sh2.Cells(j, "B") = sh1.Cells(i, "C")
      sh2.Cells(j, "C") = sh1.Cells(i, "E")
      j = j + 1
    End If
  Next
End Sub

SHEET EVENT
Right click the tab of the destination sheet you want this to work, select view code and paste the code into the window that opens up.

Update the source sheet, when you activate the destination sheet automatically all the information will be updated.