VBA Macro to transpose 4 columns into two columns

[nutbolt]

Hi I've been looking at a lot of transpose demos, still can't get what I need to do this so let me explain. I have a four column table and I am looking to Transpose it over to a two column table or array?
It will reuse the column headers so I'm thinking a loop for them and a counter to increment, I'm confused if it can be done in Array or transpose. My image is below to help explain it. I'm looking for the table to become the two columns with data like that under it.

 

[nutbolt]

coulbeit.xlsm
	A	B	C	D
1	Email	Number	Name	Status
2	bob@aol.com	123	bobby Ball	Home
3	fred@aol.com	777	Freddy Starr	Work
4	jim@lie.net	555	Jim Jimbob	Work
5	sue@fre.com	333	Sue Suspect	Home
Data

 

[nutbolt]

anyone?

 

[Peter_SSs]

Is this what you want?

Sub Rearrange()
  Dim a As Variant, Hdr As Variant
  Dim i As Long, r As Long
  
  a = Range("A1", Range("D" & Rows.Count).End(xlUp)).Value
  Hdr = Application.Transpose(Application.Index(a, 1, 0))
  r = Range("A" & Rows.Count).End(xlUp).Row - 2
  For i = 2 To UBound(a)
    r = r + 5
    Range("A" & r).Resize(4).Value = Hdr
    Range("B" & r).Resize(4).Value = Application.Transpose(Application.Index(a, i, 0))
  Next i
End Sub

 

[Alex Blakenburg]

If you add this before the "Next i" in Peter's code it will restore the hyperlink for the email address.

    Range("B" & r).Hyperlinks.Add Anchor:=Range("B" & r), Address:="mailto:" & Range("B" & r).Value

 

[Peter_SSs]

restore the hyperlink for the email address.

Good point.

Another way to retain those would be ..

Sub Rearrange_v2()
  Dim r As Range
  Dim i As Long
  
  Set r = Range("A1", Range("D" & Rows.Count).End(xlUp))
  For i = 2 To r.Rows.Count
    Union(r.Rows(1), r.Rows(i)).Copy
    Range("A" & Rows.Count).End(xlUp).Offset(2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
  Next i
  Application.CutCopyMode = False
End Sub

 

[Alex Blakenburg]

Good point.

Another way to retain those would be ..

That did a nice job of keeping a all the formatting as well as the hyperlinks.

 

[nutbolt]

Good point.

Another way to retain those would be ..

Sub Rearrange_v2()
  Dim r As Range
  Dim i As Long
 
  Set r = Range("A1", Range("D" & Rows.Count).End(xlUp))
  For i = 2 To r.Rows.Count
    Union(r.Rows(1), r.Rows(i)).Copy
    Range("A" & Rows.Count).End(xlUp).Offset(2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
  Next i
  Application.CutCopyMode = False
End Sub

works great thanks

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.