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.

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

[/COLOR]'---- 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[COLOR=#333333]

 

[wideboydixon]

Hi there. Can you give an indication of what's not working with the code?

WBD

 

[MickG]

Try this for Column "P" sheet1 Data to Column "A" sheet2.
If this leaves any test with original delimiter please supply a comprehensive list of said delimiters.

[COLOR="Navy"]Sub[/COLOR] MG20Sep04
[COLOR="Navy"]Dim[/COLOR] sp [COLOR="Navy"]As[/COLOR] Variant, Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Del [COLOR="Navy"]As[/COLOR] Variant, D [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray() [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("P1", .Range("P" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
Del = Array(39, 44, 46, 47, 58, 59)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not IsEmpty(Dn.Value) [COLOR="Navy"]Then[/COLOR]
    Txt = Dn.Value
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] D [COLOR="Navy"]In[/COLOR] Del
            Txt = Replace(Txt, Chr(D), ",")
        [COLOR="Navy"]Next[/COLOR] D
            sp = Split(Txt, ",")
            [COLOR="Navy"]For[/COLOR] n = 0 To UBound(sp)
                ReDim Preserve Ray(c)
                Ray(c) = sp(n)
                c = c + 1
            [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c)
   .Value = Application.Transpose(Ray)
   .Sort .Range("A1"), order1:=xlAscending '[COLOR="Green"][B], Header:=xlYes[/B][/COLOR]
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick