Copy column from one sheet to another then sort and remove multiple delimiters

[Daph1990]

Hi All,

I'm really hoping someone can help me with this, been trying to get this to work for a couple of days now. I am working on a sheet that has multiple columns and what I want to do is copy column P from sheet1 onto column A on sheet2. As there are blanks in the column I then need to sort to remove the blanks then there are (in some cases) more than one value in a single cell and it is possible that there could be multiple delimiters separating these values ie. 12345,6789;9876:543/21.0'123 etc. What I then want the code to be able to do is perform a text to rows and where there is more than one value, place it in the cell below etc.

I have attached the example workbook to make it easier. And the below is the code I have so far that won't work and is probably rather complex.

Thank you so much for any help given

'---- Macro to extract supplier numbers and paste them onto a new sheet

Application.ScreenUpdating = 0


Dim sColumn As Range, tColumn As Range


With Sheets("All Contracts")
    Set sColumn = .Columns("P")
    Set tColumn = Sheets("Sheet3").Columns("A")


    sColumn.Copy Destination:=tColumn
End With


    ActiveWorkbook.Worksheets("Sheet3").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet3").Sort.SortFields.Add Key:=Range("A3"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet3").Sort
        .SetRange Range("A:A")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
    Dim src As Range
    Dim result As Variant


    For Each src In Worksheets("Sheet3").Range("A:A").SpecialCells(xlCellTypeConstants)
        result = Split(Replace(src, "/", ","), ",")


        'last cell in column B
        With Worksheets("Sheet3").Cells(Rows.Count, 2).End(xlUp)
            Worksheets("Sheet3").Range(.Offset(1, 0), .Offset(1 + UBound(result, 1), 0)) = Application.WorksheetFunction.Transpose(result)
        End With
    Next src
        
    MsgBox "Supplier Vendor Numbers suceessfully extracted to Sheet 3. Please proceed to Step 6.", vbInformation, "Successful!"


Application.ScreenUpdating = 1

[mdmackillop]

Sub Test()
    Dim ws As Worksheet
    Dim i As Long
    Application.ScreenUpdating = False
    Set ws = Sheets.Add
    With ws
        Sheets("Sheet1").Columns("P:P").Copy .Range("A1")
        .Columns(1).TextToColumns Destination:=.Range("A1"), DataType:=xlDelimited, _
                                  TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                                  Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
                                                                                           :=Array(1, 1), TrailingMinusNumbers:=True
        Set r = .UsedRange
        For i = 2 To r.Columns.Count
            j = i - 1
            With r.Columns(i)
            Set c = r.Columns(i).Find("*")
            Do
                Set d = c
                c.Offset(j).EntireRow.Insert
                c.Copy c.Offset(j, -j)
                Set c = .FindNext(c)
                d.ClearContents
            Loop Until c Is Nothing
            End With
        Next i
        .Columns(1).SpecialCells(xlCellTypeBlanks).Delete
    End With
    Application.ScreenUpdating = True
End Sub

[Daph1990]

Omg you're amazing!!! Just one thing, why does the code need to add another sheet?

[mdmackillop]

Not necessary but easier for my testing. Change to

Set ws = Sheets("Sheet2")

[Daph1990]

Thank you so much, worked like a charm. Just to be cheeky, there was one other thing, how would I delete the duplicates from the column?

[mdmackillop]

Use data/RemoveDuplicates or amend the end of the code to

 With .Columns(1)
        .SpecialCells(xlCellTypeBlanks).Delete
        .RemoveDuplicates Columns:=1, Header:=xlYes
        End With

[Daph1990]

Thanks for your speedy response, you're literally a life saver! With that remove duplicate part I get the error "This operation in attempting to change a filtered range on your worksheet and cannot be completed. To complete this operation, AutoFilters in the sheet need to be removed."

[Daph1990]

I've figured it out now. Thanks again. Have a good day!