Hi fikkie2002,
Try the below macro based on your sample file, once you run the code a message box will pop-up asking you "Run macro for Horizontal data?" with 3 options Yes, No or Cancel ... Yes will run the code for Horizontal no will run for Vertical & cancel will abort the macro
Sub test_2()
Dim a, ReportType
ReportType = MsgBox("Run macro for Horizontal data?", vbYesNoCancel)
If ReportType = vbCancel Then Exit Sub
If ReportType = vbYes Then Columns(1).NumberFormat = "@" Else Rows(1).NumberFormat = "@"
a = IIf(ReportType = vbYes, [A1].CurrentRegion, Application.Transpose([A1].CurrentRegion))
With CreateObject("scripting.dictionary")
For x = 1 To UBound(a)
For y = 2 To UBound(a, 2)
If Len(a(x, y)) > 0 Then If Not .exists(a(x, 1)) Then .Add a(x, 1), a(x, y) Else .Item(a(x, 1)) = .Item(a(x, 1)) & ";" & a(x, y)
Next
Next
a = Application.Transpose(Array(.keys, .items))
End With
With ActiveSheet
.UsedRange.Clear
.[A1].Resize(UBound(a)).NumberFormat = "@"
.[A1].Resize(UBound(a), 2) = a
.[B1].Resize(UBound(a)).TextToColumns [B1], semicolon:=True
If ReportType = vbNo Then
a = .[A1].CurrentRegion
.UsedRange.Clear
.[A1].Resize(, UBound(a, 2)).NumberFormat = "@"
.[A1].Resize(UBound(a, 2), UBound(a)) = Application.Transpose(a)
End If
End With
End Sub
Bookmarks