Macro for hierarchical Setup?

Sorry, your layout makes little sense. Could you please upload a workbook?

Attach a sample workbook. Make sure there is just enough data to demonstrate your need. Include a BEFORE sheet and an AFTER sheet in the workbook if needed to show the process you're trying to complete or automate. Make sure your desired results are shown, mock them up manually if necessary.

Remember to desensitize the data.

Click on GO ADVANCED and use the paperclip icon to open the upload window.

View Pic

Sure thing, I updated the original post. I am given data similar to what is in the table and I need to turn it into what is shown below the table.

Sorry about the confusion.

IS it for an unknown number of columns?

At this point in time it is for 10 columns. 1 for classification, 1 for method, and 8 verification procedures. So YUIH-1 (and other values in column 2/B) are the method and columns 3/C to 5/E (up to 10/J) signify ways to verify that method.

This should get it, works for the sample data at least, adjust ranges to suit:

Dim base        As Dictionary
Dim data        As Variant
Dim x           As Long
Dim totalRows   As Long
Dim a, b, c

Set base = New Dictionary
data = Sheets("sheet1").Range("A2:E7").Value2
Dim keyCount As Long
keyCount = -1


For x = LBound(data) To UBound(data)
    If Not base.Exists(data(x, 1)) And Len(data(x, 1)) > 1 Then
        Set base(data(x, 1)) = New Dictionary
        keyCount = keyCount + 1
        totalRows = totalRows + 1
    ElseIf Len(data(x, 1)) = 0 Then
        If Not base.Exists(data(x, 2)) And Len(data(x, 2)) > 1 Then
           Set base(base.Keys()(keyCount))(data(x, 2)) = New Dictionary
           For y = 3 To UBound(data, 2)
                If (Len(data(x, y)) > 0) Then base(base.Keys()(keyCount))(data(x, 2)).Add x & y, data(x, y)
                totalRows = totalRows + 1
           Next y
        End If
    End If
Next x

ReDim data(1 To totalRows, 1 To 3)
x = 1

For Each a In base.Keys()
    'Debug.Print a
    data(x, 1) = a
    x = x + 1
    For Each b In base(a).Keys()
        'Debug.Print , b
        data(x, 2) = b
        x = x + 1
        For Each c In base(a)(b).Keys()
            'Debug.Print , , c
            data(x, 3) = base(a)(b)(c)
            x = x + 1
        Next c
    Next b
Next a


Sheets(2).Range("a1:c" & totalRows).Value = data

Requires a reference to Microsoft Scripting Runtime, otherwise this requires no references:

Dim base        As Object
Dim data        As Variant
Dim x           As Long
Dim totalRows   As Long
Dim a, b, c

Set base = CreateObject("Scripting.Dictionary")
data = Sheets("sheet1").Range("A2:E7").Value2
Dim keyCount As Long
keyCount = -1


For x = LBound(data) To UBound(data)
    If Not base.Exists(data(x, 1)) And Len(data(x, 1)) > 1 Then
        Set base(data(x, 1)) = CreateObject("Scripting.Dictionary")
        keyCount = keyCount + 1
        totalRows = totalRows + 1
    ElseIf Len(data(x, 1)) = 0 Then
        If Not base.Exists(data(x, 2)) And Len(data(x, 2)) > 1 Then
           Set base(base.Keys()(keyCount))(data(x, 2)) = CreateObject("Scripting.Dictionary")
           For y = 3 To UBound(data, 2)
                If (Len(data(x, y)) > 0) Then base(base.Keys()(keyCount))(data(x, 2)).Add x & y, data(x, y)
                totalRows = totalRows + 1
           Next y
        End If
    End If
Next x

ReDim data(1 To totalRows, 1 To 3)
x = 1

For Each a In base.Keys()
    'Debug.Print a
    data(x, 1) = a
    x = x + 1
    For Each b In base(a).Keys()
        'Debug.Print , b
        data(x, 2) = b
        x = x + 1
        For Each c In base(a)(b).Keys()
            'Debug.Print , , c
            data(x, 3) = base(a)(b)(c)
            x = x + 1
        Next c
    Next b
Next a


Sheets(2).Range("a1:c" & totalRows).Value = data