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!