Manage multivalued attributes

[Tuanfeng]

Hi there,

I've got a task to design a dimensional data model and group data accordingly in excel. While doing that, I discovered that one of the dimensions consisted of multivalued attributes (i.e. one-to-many relationship), which had to be converted into multiple one-to-one relationships in excel. Attached is the file with sample data, where Sheet 1 is the current situation, and Sheet 2 is what I would like to achieve. Please help me out. Thanks a lot.

(NOTE: The actual workbook consists of almost a million rows, so I would really appreciate it if the codes do not have many repetitive processes that need to be written)

[JOHN H. DAVIS]

Maybe:

Sub tuanfeng()
Dim y As Long
Dim z As Long
Dim rcell As Range
Dim x As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
    Range("B1:B" & Range("A" & Rows.count).End(3)(1).Row).Select
    Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=True, FieldInfo:= _
        Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
For z = Range("A" & Rows.count).End(3)(1).Row To 2 Step -1
x = 1
    For y = 3 To ActiveSheet.UsedRange.Columns.count + 1
        If Cells(z, y).Value <> "" Then
            Cells(z, y).offset(1).EntireRow.Insert
            Cells(z + 1, "A").Value = Cells(z, "A").Value
            Cells(z, y).Cut Cells(z + 1, "B")
            Cells(z + 1, "C").Value = x
        End If
        x = x + 1
    Next y
Next z
For Each rcell In Range("C2:C" & Range("A" & Rows.count).End(3)(1).Row)
    If rcell.Value <> "" And rcell.offset(1).Value <> "" Then
        Range(Cells(rcell.Row, "A"), Cells(rcell.Row + 1, "C")).Select
            Selection.Sort Key1:=Range("C" & rcell.Row), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        Range(Cells(rcell.Row, "C"), Cells(rcell.Row + 1, "C")).Clear
    End If
Next rcell
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

[Tuanfeng]

You are a hero!!!!!! Thanks a lot!!

[JOHN H. DAVIS]

You're welcome. Glad to help out and thanks for the feedback.

[TMS]

I know you have a solution, but, just for fun, another option:

' Module: mOneToMany

'Option Private Module
Option Explicit

Sub sOneToMany()

Dim lLR As Long, lNR As Long
Dim i As Long, j As Long
Dim vx1, vy2, vRequest
Const sInput As String = "Sheet1"
Const sOutput As String = "Sheet2"

Dim sw As New StopWatch
sw.StartTimer
Debug.Print "Start: ", Time
    
Application.ScreenUpdating = False
Sheets(sOutput).Cells.Delete

With Sheets(sInput)
    lLR = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("A1:B1").Copy _
        Sheets(sOutput).Range("A1")
End With

For i = 2 To lLR
    With Sheets(sInput)
        vRequest = .Range("A" & i)
        If .Range("B" & i) = "" Then GoTo lblSkip
        vx1 = Split(.Range("B" & i), ",")
        ReDim vy2(LBound(vx1) To UBound(vx1), 1 To 2)
        For j = LBound(vx1) To UBound(vx1)
            vy2(j, 1) = vRequest: vy2(j, 2) = vx1(j)
        Next 'j
    End With
    With Sheets(sOutput)
        lNR = .Range("B" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & lNR).Resize(UBound(vx1) + 1, 2).Value = vy2
    End With
lblSkip:
Next 'i

Sheets(sOutput).Range("A1:B1").EntireColumn.AutoFit
Application.ScreenUpdating = True

Debug.Print "End: ", Time
Debug.Print "sOneToMany took: " & sw.EndTimer & " milliseconds."

End Sub

Some differences to note:
1. John's code operates on the Active Sheet and overwrites it
2. My code writes the output to a new sheet which must pre-exist (in this case, Sheet2)
3. I've added a timer routine so you can compare times. Bit of a movable feast depending on the foibles of the machine.
Sometimes one is faster, then the other ... but not a lot in it
4. The timer will not work in 64 bit installations of Excel


Regards, TMS

[Tuanfeng]

Thanks TMS. Always nice to have an alternative solution.

[TMS]

You're welcome. Thanks for the rep.

[TMS]

This version caters for the scenario where there is a Request ID but no associated Linked Services.

' Module: mOneToMany_V2

'Option Private Module
Option Explicit

Sub sOneToMany_V2()

Dim lLR As Long, lNR As Long
Dim i As Long, j As Long
Dim vx1, vy2, vRequest
Const sInput As String = "Sheet1"
Const sOutput As String = "Sheet2"

Dim sw As New StopWatch
sw.StartTimer
Debug.Print "Start: ", Time
    
Application.ScreenUpdating = False
Sheets(sOutput).Cells.Delete

With Sheets(sInput)
    lLR = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("A1:B1").Copy _
        Sheets(sOutput).Range("A1")
End With

For i = 2 To lLR
    With Sheets(sInput)
        vRequest = .Range("A" & i)
        If .Range("B" & i) = "" Then GoTo lblSkip
        vx1 = Split(.Range("B" & i), ",")
        ReDim vy2(LBound(vx1) To UBound(vx1), 1 To 2)
        For j = LBound(vx1) To UBound(vx1)
            vy2(j, 1) = vRequest: vy2(j, 2) = vx1(j)
        Next 'j
    End With
    With Sheets(sOutput)
        lNR = .Range("B" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & lNR).Resize(UBound(vx1) + 1, 2).Value = vy2
    End With
    GoTo lblNext

lblSkip:
    With Sheets(sOutput)
        lNR = .Range("B" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & lNR) = vRequest
        .Range("B" & lNR) = "$$no entries$$"
    End With

lblNext:
Next 'i

With Sheets(sOutput).Range("A1:B1").EntireColumn
    .Replace What:="$$no entries$$", _
             Replacement:="", _
             LookAt:=xlWhole
    .AutoFit
End With

Application.ScreenUpdating = True

Debug.Print "End: ", Time
Debug.Print "sOneToMany took: " & sw.EndTimer & " milliseconds."

End Sub

Regards, TMS

[Tuanfeng]

Thank you TMS!