2 Lists From 1 With Dividers (Update Current VBA)

[kingsolo]

How would I go about making the VBA split the data into 2 lists (Multi & Single) based on an X placed in a column? I have VBA to do the lists how I needed them, now a new criteria requires me to split the lists.

See the OUTPUT tab to see what the VBA produces now, vs what I need as the new need as the new product.

Thanks in advance!

https://1drv.ms/x/s!Aoa335Q8qKqRmWwYtP3AD1HSAOEm

 

[kingsolo]

Didnt realize some might not want to download the sheet. Apologies. This is the VBA i currently have. But I need it to check for an X in column D of tab "Input". If it is there, it would go under the MULTI heading, those that do not have an X in column D would go under the SINGLE heading. there would be a divider of 10 dashes (----------) between the last person under the MULTI heading and the SINGLE heading. Hope I explained that properly.

Sub getList()   Dim Cl As Range
   Dim Lst As Object
   Dim X As String
   
   Set Lst = CreateObject("system.collections.arraylist")
   With Lst
      For Each Cl In Range("A7", Range("A" & Rows.Count).End(xlUp))
         If Cl.Offset(, 1).Value < Range("B4").Value Then
            X = Join(Application.Index(Cl.Resize(, 3).Value, 1, 0), ",")
            X = Replace(X, ",,", ",")
            If Right(X, 1) = "," Then X = Left(X, Len(X) - 1)
            .Add X
         Else
            If Cl.Offset(, 2) = "" Then
               .Add Cl.Value
            Else
               .Add Cl.Value & "," & Cl.Offset(, 2).Value
            End If
         End If
         
      Next Cl
      .Sort
      Sheets("Output").Range("a2").Resize(.Count).Value = Application.Transpose(.toarray)
   End With
   With Sheets("Output").Range("A" & Rows.Count).End(xlUp).Offset(1)
      .Value = String(10, "-")
      Range("E7", Range("E" & Rows.Count).End(xlUp)).Copy .Offset(1)
   End With
         
End Sub

 

[Fluff]

How about

Sub getList()
   Dim Cl As Range
   Dim SLst As Object, Mlst As Object
   Dim X As String
   
   Set SLst = CreateObject("system.collections.arraylist")
   Set Mlst = CreateObject("system.collections.arraylist")
   For Each Cl In Range("A7", Range("A" & Rows.Count).End(xlUp))
      If Cl.Offset(, 1).Value < Range("B4").Value Then
         X = Join(Application.Index(Cl.Resize(, 3).Value, 1, 0), ",")
         X = Replace(X, ",,", ",")
         If Right(X, 1) = "," Then X = Left(X, Len(X) - 1)
         If LCase(Cl.Offset(, 3)) = "x" Then Mlst.Add X Else SLst.Add X
      ElseIf Cl.Offset(, 2) = "" Then
         If LCase(Cl.Offset(, 3)) = "x" Then Mlst.Add Cl.Value Else SLst.Add Cl.Value
      Else
         X = Cl.Value & "," & Cl.Offset(, 2).Value
         If LCase(Cl.Offset(, 3)) = "x" Then Mlst.Add X Else SLst.Add X
      End If
   Next Cl
   Mlst.Sort
   SLst.Sort
   With Sheets("Output")
      .Range("a2").Resize(Mlst.Count).Value = Application.Transpose(Mlst.toarray)
      .Range("A" & Rows.Count).End(xlUp).Offset(1) = String(10, "-")
      .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(SLst.Count).Value = Application.Transpose(SLst.toarray)
      .Range("A" & Rows.Count).End(xlUp).Offset(1) = String(10, "-")
      Range("E7", Range("E" & Rows.Count).End(xlUp)).Copy .Range("A" & Rows.Count).End(xlUp).Offset(1)
   End With
   
End Sub

 

[kingsolo]

Worked like a champ! Thanks!

 

[kingsolo]

Well, thought it was running great till I ran a report that didnt have any entries with a X in the multi column. Caused an error at the line:

.Range("a2").Resize(Mlst.Count).Value = Application.Transpose(Mlst.toarray)

 

[Fluff]

OK, try

Sub getList()
   Dim Cl As Range
   Dim SLst As Object, Mlst As Object
   Dim X As String
   
   Set SLst = CreateObject("system.collections.arraylist")
   Set Mlst = CreateObject("system.collections.arraylist")
   For Each Cl In Range("A7", Range("A" & Rows.Count).End(xlUp))
      If Cl.Offset(, 1).Value < Range("B4").Value Then
         X = Join(Application.Index(Cl.Resize(, 3).Value, 1, 0), ",")
         X = Replace(X, ",,", ",")
         If Right(X, 1) = "," Then X = Left(X, Len(X) - 1)
         If LCase(Cl.Offset(, 3)) = "x" Then Mlst.Add X Else SLst.Add X
      ElseIf Cl.Offset(, 2) = "" Then
         If LCase(Cl.Offset(, 3)) = "x" Then Mlst.Add Cl.Value Else SLst.Add Cl.Value
      Else
         X = Cl.Value & "," & Cl.Offset(, 2).Value
         If LCase(Cl.Offset(, 3)) = "x" Then Mlst.Add X Else SLst.Add X
      End If
   Next Cl
   Mlst.Sort
   SLst.Sort
   With Sheets("Output")
      If Mlst.Count > 0 Then .Range("a2").Resize(Mlst.Count).Value = Application.Transpose(Mlst.toarray)
      .Range("A" & Rows.Count).End(xlUp).Offset(1) = String(10, "-")
      If SLst.Count > 0 Then .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(SLst.Count).Value = Application.Transpose(SLst.toarray)
      .Range("A" & Rows.Count).End(xlUp).Offset(1) = String(10, "-")
      Range("E7", Range("E" & Rows.Count).End(xlUp)).Copy .Range("A" & Rows.Count).End(xlUp).Offset(1)
   End With
   
End Sub

 

[kingsolo]

Thanks... that got it!

 

[Fluff]

You're welcome & thanks for the feedback