Daph1990
09-20-2017, 04:01 AM
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
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