Splitting data into multiple columns and adding range names

[dougebowl]

I have a spreadsheet and am needing help splitting the data into multiple columns and adding name ranges.

Spreadsheet has 5 columns (A-E)

Columns C, D, and E are related. Column C contains an Inventory Name, Column D contains a Parent Rule, and Column E contains a Child rule.

I need the data from these 3 columns to be split in the following manner:

Individual column containing a list of the unique Inventory Names - Name the range "InventoryName"
Individual columns for all the Parent Rules associated to the same Inventory Name = Name the range the associated Inventory Name
Individual columns for all the Child Rules associated with the same Parent Rule - Name the range the associated Parent Rule

Ultimately, I am looking to create Indirect data validation drop downs that only show the Parent Rules associated to the Inventory Name selected, then only show the Child Rules associated with the Parent Rule selected.

Thanks in advance for any assistance.

 

[Fluff]

How about

Sub SplitDataName()
   Dim Cl As Range
   Dim Dic As Object
   Dim V1 As String, V2 As String, V3 As String
   Dim Kys As Variant, Ky As Variant
   Dim Col As Long

   Set Dic = CreateObject("scripting.dictionary")
   Dic.comparemode = vbTextCompare
   With Sheets("Sheet3")
      For Each Cl In .Range("C2", .Range("C" & Rows.Count).End(xlUp))
         V1 = Cl.Value: V2 = Cl.Offset(, 1).Value: V3 = Cl.Offset(, 2).Value
         If Not Dic.exists(V1) Then
            Dic.Add V1, CreateObject("scripting.dictionary")
            Dic(V1).Add V2, CreateObject("scripting.dictionary")
            Dic(V1)(V2).Add V3, Nothing
         ElseIf Not Dic(V1).exists(V2) Then
            Dic(V1).Add V2, CreateObject("scripting.dictionary")
            Dic(V1)(V2).Add V3, Nothing
         ElseIf Not Dic(V1)(V2).exists(V3) Then
            Dic(V1)(V2).Add V3, Nothing
         End If
      Next Cl
      With .Range("H2").Resize(Dic.Count)
         .Value = Application.Transpose(Dic.keys)
         .Name = "InventoryName"
      End With
      Col = 9
      For Each Kys In Dic.keys
         With .Cells(Rows.Count, Col).End(xlUp).Offset(1).Resize(Dic(Kys).Count)
            .Value = Application.Transpose(Dic(Kys).keys)
            .Name = Kys
         End With
         Col = Col + 1
         For Each Ky In Dic(Kys)
            With .Cells(Rows.Count, Col).End(xlUp).Offset(1).Resize(Dic(Kys)(Ky).Count)
               .Value = Application.Transpose(Dic(Kys)(Ky).keys)
               .Name = Ky
            End With
            Col = Col + 1
         Next Ky
      Next Kys
   End With
End Sub

This assumes that all Inventory & Parent names are suitable for named ranges

 

[dougebowl]

I am getting a run-time error '1004' Application-defined or object-defined error for the row underlined, bold, italics below.

Also, you mention an assumption regarding the names. Inventory Names may or may not contain spaces. I believe spaces could be an issue. Also, Parent names are numerical values, I think this may be an issue as well.

Col = 9
For Each Kys In Dic.keys
With .Cells(Rows.Count, Col).End(xlUp).Offset(1).Resize(Dic(Kys).Count)
.Value = Application.Transpose(Dic(Kys).keys)
.Name = Kys
End With
Col = Col + 1
For Each Ky In Dic(Kys)
With .Cells(Rows.Count, Col).End(xlUp).Offset(1).Resize(Dic(Kys)(Ky).Count)
.Value = Application.Transpose(Dic(Kys)(Ky).keys)
.Name = Ky

 

[Fluff]

Whilst it's possible to remove any spaces & add a letter to the start of the Parent names to create valid named ranges, you wont be able to use Indirect in your data validation.
I suspect that the data itself will need to be changed

 

[Fluff]

This will remove the spaces from the output list & also add P_ to the parent numbers, to deal with the named ranges

Sub SplitDataName()
   Dim Cl As Range
   Dim Dic As Object
   Dim V1 As String, V2 As String, V3 As String
   Dim Kys As Variant, Ky As Variant
   Dim Col As Long

   Set Dic = CreateObject("scripting.dictionary")
   Dic.comparemode = vbTextCompare
   With Sheets("Sheet2")
      For Each Cl In .Range("C2", .Range("C" & Rows.Count).End(xlUp))
         V1 = Replace(Cl.Value, " ", ""): V2 = "P_" & Cl.Offset(, 1).Value: V3 = Cl.Offset(, 2).Value
         If Not Dic.Exists(V1) Then
            Dic.Add V1, CreateObject("scripting.dictionary")
            Dic(V1).Add V2, CreateObject("scripting.dictionary")
            Dic(V1)(V2).Add V3, Nothing
         ElseIf Not Dic(V1).Exists(V2) Then
            Dic(V1).Add V2, CreateObject("scripting.dictionary")
            Dic(V1)(V2).Add V3, Nothing
         ElseIf Not Dic(V1)(V2).Exists(V3) Then
            Dic(V1)(V2).Add V3, Nothing
         End If
      Next Cl
      With .Range("H2").Resize(Dic.Count)
         .Value = Application.Transpose(Dic.Keys)
         .Name = "InventoryName"
      End With
      Col = 9
      For Each Kys In Dic.Keys
         With .Cells(Rows.Count, Col).End(xlUp).Offset(1).Resize(Dic(Kys).Count)
            .Value = Application.Transpose(Dic(Kys).Keys)
            .Name = Kys
         End With
         Col = Col + 1
         For Each Ky In Dic(Kys)
            With .Cells(Rows.Count, Col).End(xlUp).Offset(1).Resize(Dic(Kys)(Ky).Count)
               .Value = Application.Transpose(Dic(Kys)(Ky).Keys)
               .Name = Ky
            End With
            Col = Col + 1
         Next Ky
      Next Kys
   End With
End Sub