Te anexo la macro.
Sub HorizontalVertical()
'Por.Dante Amor
Application.ScreenUpdating = False
Set h1 = Sheets("INFORMACION")
Set h2 = Sheets("NUEVA")
'
h1.Rows(4 & ":" & 16).UnMerge
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
h2.Range("A2:P" & u2).ClearContents
'
i = 2
For j = 2 To h1.Cells(4, Columns.Count).End(xlToLeft).Column Step 2
u = h1.Range("A" & Rows.Count).End(xlUp).Row
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
h1.Range("A19:A" & u).Copy h2.Range("A" & u2)
h1.Range(h1.Cells(19, j), h1.Cells(u, j + 1)).Copy
h2.Range("C" & u2).PasteSpecial Paste:=xlPasteValues
For i = 19 To u
h1.Cells(4, j).Copy h2.Range("B" & u2)
h1.Range(h1.Cells(5, j), h1.Cells(16, j)).Copy
h2.Range("E" & u2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
u2 = u2 + 1
Next
Next
Application.ScreenUpdating = True
h2.Select
MsgBox "Horizontal Vertical, terminado"
End Sub
Saludos.Dante Amor