Sort

**tshrader** · 12-14-2011, 05:35 PM

I need help with VBA code to perform a complex sort. Basically, I have a column of names, each with one or more duplicates, and many columns of colors. Each column represents a different color. For each name (and duplicates) in column A, there may be one or more associated colors. The same name may have one color, and the same name in the next row may have another. So, I need VBA code that will find and all colors for each unique name and place them in a column.

See the attached file for a clearer picture. Test Case - Data Manipulation.xlsx
*Please note that I have a much larger file with way more names and colors. This is just a sample.

I have tried many different ways, but without success. Any help would be greatly appreciated.

**dangelor** · 12-14-2011, 07:13 PM

Try this...

Sub FindUniqueData()
    Dim Unique As New Collection
    Dim vData As Variant, vResults As Variant
    Dim a As Long
    
    'Collect data
    vData = Worksheets("Sheet1").Range("A2:I21")
    
    'Create list of unique items
    On Error Resume Next
    For a = 1 To UBound(vData, 1)
        For b = 2 To UBound(vData, 2)
            If Not IsEmpty(vData(a, b)) Then
                Unique.Add vData(a, 1) & "," & vData(a, b), CStr(vData(a, 1) & "" & vData(a, b))
            End If
        Next b
    Next a
    On Error GoTo 0
    
    'Post List
    ReDim vResults(Unique.Count)
    For a = 1 To Unique.Count
        vResults(a) = Unique(a)
        Worksheets("Sheet2").Cells(a, 1).Resize(1, 2) = Split(vResults(a), ",")
    Next a
End Sub

**rylo** · 12-14-2011, 07:13 PM

Hi

Try this. It doesn't bring back the data in the same order, but I think it is all there.

Sub aaa()
  Dim OutSh As Worksheet
  Set OutSh = Sheets("Sheet2")
  
  OutSh.Cells.ClearContents
  'put in some dummy headings
  OutSh.Range("A1:B1").Value = Array("H1", "H2")
  Sheets("Sheet1").Activate
  
  For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    For j = 2 To 9
      If Len(Cells(i, j)) > 0 Then
        outrow = OutSh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        OutSh.Cells(outrow, 1).Value = Cells(i, 1).Value
        OutSh.Cells(outrow, 2).Value = Cells(i, j).Value
      End If
    
    Next j
  Next i
  
  OutSh.Range("A:B").AdvancedFilter Action:=xlFilterCopy, copytorange:=OutSh.Range("C1:D1"), unique:=xlYes
  
  OutSh.Range("A:B").Delete
  OutSh.Rows("1:1").Delete
  
  For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    If WorksheetFunction.CountIf(OutSh.Range("A:A"), Cells(i, 1)) = 0 Then
      OutSh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = Cells(i, 1).Value
    End If
  
  Next i
  
End Sub

rylo

**Richard Buttrey** · 12-14-2011, 07:13 PM

Hi,

One way

Sub ListColours()
    Dim lNames As Long, lColours As Long, x As Long, y As Long, c As Long, llastrow As Long
    lNames = Sheet1.Range("A2").CurrentRegion.Rows.Count - 1
    lColours = Sheet1.Range("A2").CurrentRegion.Columns.Count - 1
    Sheet2.Range("A1:B1") = "Names"

    For x = 1 To lNames
        For y = 1 To lColours

            If Sheet1.Cells(x + 1, y + 1) <> "" Then
                Sheet2.Range("A" & Rows.Count).End(xlUp).Cells(2, 1) = Sheet1.Cells(x + 1, 1) & "_" & _
                Sheet1.Cells(x + 1, y + 1)
                c = c + 1
            End If
        Next y
        If c = 0 Then
            Sheet2.Range("A" & Rows.Count).End(xlUp).Cells(2, 1) = Sheet1.Cells(x + 1, 1)
        End If
        c = 0
    Next x

    Range(Sheet2.Range("A1"), Sheet2.Range("A" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, copytorange:=Sheet2.Range("B1"), unique:=True
    Sheet2.Columns("B:B").TextToColumns Destination:=Sheet2.Range("B1"), DataType:=xlDelimited, _
                                        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
                                        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
                                                                                                   :="_", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

    Range("A:A").EntireColumn.delete
    Sheet2.Range("B1") = "Colours"
    llastrow = Range("A" & Rows.Count).End(xlUp).Row
    Sheet2.Range("C2") = "=IF(AND(COUNTIF(A:A,A2)>1,B2=""""),""Delete"","""")"
    Sheet2.Range("C2").Copy Destination:=Sheet2.Range("C2:C" & llastrow)
    Sheet2.Range("A1").AutoFilter
    Sheet2.Range("$A$1").CurrentRegion.AutoFilter Field:=3, Criteria1:="<>"
    Range("A2").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.delete
    Sheet2.Range("A1").AutoFilter


End Sub

**tshrader** · 12-14-2011, 09:37 PM

Wow, you all are very talented, thanks!! Dangelor and Rylo's code worked exactly as I imagined. Richard Buttrey's code worked as well but wasn't quite as refined. I didn't imagine I would have options for code! You are all impressive and I hope you accept my greatest thank you. Thank you!

Thread: Sort

Thread Tools

Display

Sort

Re: Sort

Re: Sort

Re: Sort

Re: Sort

Thread Information

Users Browsing this Thread

Tags for this Thread

Bookmarks

Bookmarks

Posting Permissions