Transpose multiple rows to one column keping the row header.

So, I have many lists of emails and I need to create one list that has each email address (and only the email address) in a column with the email group specified on the left.

Gonna have to do this on a periodic basis with large amounts of data starting... well... earlier today... so any help will be much appreciated!

What I get, what I ended up with after text to columns & some text chopping, and what I actually need is in the file attached.

Thanks!

Hi

You will have to modify to suit your real data structure...

Sub aaa()
  Dim OutSH As Worksheet
  Set OutSH = Sheets("Sheet2")
  
  Sheets("Sheet1").Select
  
  For Each ce In Range("A3:A5")
    arr = Split(ce.Offset(0, 1), "; ")
    For i = LBound(arr) To UBound(arr)
      outrow = OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
      OutSH.Cells(outrow, 1).Value = ce.Value
      OutSH.Cells(outrow, 2).Value = arr(i)
    Next i
  Next ce
  
  OutSH.Range("B:B").Replace what:="Alias <", replacement:=""
  OutSH.Range("B:B").Replace what:=">", replacement:=""
  
End Sub

rylo

check attachment, run macro "test"