Split content in one cell and copy to new rows while keeping rest of columns intact

[Jacob Petersen]

Dear Experts.

I have a data set where all product information is distributed correctly in separate cells. However, one cell contains the ‘price history’ of the product. The information is semi-colon separated, but both the date and the price are included in this cell, and sometimes up to 20 different dates and prices (fx. 18 Jun 2013=1897.25;24 Jul 2013=1882.71;15 Jul 2016=1882.71).
I am looking for a macro/smart function to add a new row for each unique date and price, based on the column containing the price history information.

Please see the attached Excel sheet.

The purpose of the split is a visual/data presentation of the historic prices.

An additional note, but not as important. If you have the solution for adjusting the pivot charts to only display information where data is present, feel free to share it. It will be evident if you open the ‘sample’ Excel sheet.

I am using Excel 2016.

 

[Luke M]

Hi Jacob,

Don't have time atm to fully answer split problem, but I can solve the PT issue. It's easier to do the filtering if you click on PT, then go to Design - Report Layout - Tabular. Then you can apply a Value filter to the months, where you only show items > 0. This will make the charts the way you want them. Hopefully someone else can use this to finish the problem. =/

 

[Jacob Petersen]

Hi Luke,
Thank you for getting back on the PT issue, I really appreciate it!
Crossing my fingers that someone has time, and can figure it out

 

[jindon]

Try

Sub test()
    Dim a, i As Long, ii As Long, iii As Long, n As Long, t As Long, txt As String
    Dim m As Object, myDate, myVal As Double, e, x, w, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    a = Sheets("Data and Dashboard").Range("b3").CurrentRegion.Value
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "([^;=]*?)=(.*?)(;|$)"
        For i = 2 To UBound(a, 1)
            txt = a(i, 1)
            For ii = 2 To 6: txt = txt & Chr(2) & a(i, ii): Next
            ReDim w(1 To 2)
            Set w(1) = CreateObject("Scripting.Dictionary")
            Set w(2) = CreateObject("System.Collections.SortedList")
            dic(txt) = w
            For ii = 7 To UBound(a, 2)
                Set dic(txt)(1)(ii) = CreateObject("Scripting.Dictionary")
                dic(txt)(1)(ii).CompareMode = 1
                For Each m In .Execute(a(i, ii))
                    myDate = m.submatches(0)
                    If myDate Like "[0-9]* [ADJFMNOS]* *" Then
                        myDate = CDate(myDate)
                        myVal = Val(m.submatches(1))
                        dic(txt)(2)(myDate) = Empty
                        dic(txt)(1)(ii)(myDate) = myVal
                    End If
                Next
            Next
        Next
    End With
    ReDim a(1 To 10000, 1 To UBound(a, 2) + 1)
    For Each e In dic
        x = Split(e, Chr(2)): n = n + 1: t = 0
        For i = 0 To dic(e)(2).Count - 1
            For ii = 0 To UBound(x)
                a(n + t, ii + 1) = x(ii)
            Next
            a(n + t, 7) = dic(e)(2).GetKey(i): t = t + 1
        Next
        For ii = n To n + t - 1
            For iii = 8 To UBound(a, 2)
                a(ii, iii) = dic(e)(1)(iii - 1)(a(ii, 7))
            Next
        Next
        n = n + t - 1
    Next
    With Sheets.Add
        Sheets("Data and Dashboard").[b3].CurrentRegion.Rows(1).Copy .Cells(1)
        .Columns(7).Insert: .Cells(1, 7).Value = "Historic price date"
        .[a2].Resize(n, UBound(a, 2)).Value = a
        .Columns.AutoFit
    End With
End Sub

 

[Jacob Petersen]

Hi Jindon,
You are a genius.
I thought it would be rather easy to implement the code into the original data set, but that was not the case after hours of trying, and your codes are really advance.
I have a total of 45 columns, and cannot figure out how to modify the code to copy the rest of the cells.
Would it be possible for me to send you the original data-set through a private message?

If not, thank you so much for your help anyways, I will try to figure something out.

 

[jindon]

You can post your workbook here with the same sheet layouts with dummy data and the results that you want.

 

[Jacob Petersen]

I can't thank you enough Jindon.

Attached you will find the workbook.

 

[jindon]

See the change...

Sub test()
    Dim a, i As Long, ii As Long, iii As Long, n As Long, t As Long, txt As String
    Dim m As Object, myDate, myVal As Double, e, x, y, w, dic As Object
    Const Pref As Long = 35, suf As Long = 39  '<--- setting col ref.
    Set dic = CreateObject("Scripting.Dictionary")
    a = Sheets("Sheet1").Range("b3").CurrentRegion.Value
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "([^;=]*?)=(.*?)(;|$)"
        For i = 2 To UBound(a, 1)
            txt = a(i, 1)
            For ii = 2 To Pref: txt = txt & Chr(2) & a(i, ii): Next
            txt = txt & Chr(1)
            For ii = suf To UBound(a, 2): txt = txt & Chr(2) & a(i, ii): Next
            ReDim w(1 To 2)
            Set w(1) = CreateObject("Scripting.Dictionary")
            Set w(2) = CreateObject("System.Collections.SortedList")
            dic(txt) = w
            For ii = Pref + 1 To suf - 1
                Set dic(txt)(1)(ii) = CreateObject("Scripting.Dictionary")
                dic(txt)(1)(ii).CompareMode = 1
                For Each m In .Execute(a(i, ii))
                    myDate = m.submatches(0)
                    If myDate Like "[0-9]* [ADJFMNOS]* *" Then
                        myDate = CDate(myDate)
                        myVal = Val(m.submatches(1))
                        dic(txt)(2)(myDate) = Empty
                        dic(txt)(1)(ii)(myDate) = myVal
                    End If
                Next
            Next
        Next
    End With
    ReDim a(1 To 10000, 1 To UBound(a, 2) + 1)
    For Each e In dic
        x = Split(Split(e, Chr(1))(0), Chr(2))
        y = Split(Split(e, Chr(1))(1), Chr(2))
        n = n + 1: t = 0
        For i = 0 To dic(e)(2).Count - 1
            For ii = 0 To UBound(x)
                a(n + t, ii + 1) = x(ii)
            Next
            For ii = 0 To UBound(y)
                a(n + t, ii + suf) = y(ii)
            Next
            a(n + t, Pref + 1) = dic(e)(2).GetKey(i): t = t + 1
        Next
        For ii = n To n + t - 1
            For iii = Pref + 2 To suf
                a(ii, iii) = dic(e)(1)(iii - 1)(a(ii, Pref + 1))
            Next
        Next
        n = n + t - 1
    Next
    With Sheets.Add
        Sheets("Sheet1").[b3].CurrentRegion.Rows(1).Copy .Cells(1)
        .Columns(Pref + 1).Insert: .Cells(1, Pref + 1).Value = "Historic price date"
        .Columns(Pref + 1).NumberFormat = "d-mmm-yy"
        .[a2].Resize(n, UBound(a, 2)).Value = a
        .Columns.AutoFit
    End With
End Sub

 

[Jacob Petersen]

Hi Jindon,
Thank you so much, the conversion works perfectly, it's extremely fast and efficient.

There is another issue though. Is to possible to store the copied prices as values instead of text (column Z-AI in the original data set)? I have looked around, and it does not seem like there is an easy fix. The usual Excel function (help box) allowing me to 'convert to Number' takes ages, since my new dataset has 18,000 rows.

Your converted historic prices are correctly formatted as numbers.

Also, it does not seem to be handling the copied prices that well (some of the cells containing a formula, columns AE-AI) ). For example ID 19, is copied as 170802552594481 for € cost, whereas in the original dataset it is shown as 1,7080.

I am guessing this issue has to do with that my Danish Excel is using Commas instead of dots to write decimals?

Furthermore, this code was giving some issues: myDate = CDate(myDate)
In Danish the abbreviation for months are different than English (only for October and May though, in Danish it is Okt and Maj) - Using the replace function before running the code helped on this issue.

Is it possible to a give you a donation somehow for your work? You have saved me so much time, and your work will be of a great value to me.

 

[jindon]

1) This should convert string value to numeric value

Sub ConvertToNumber()
    With Sheets("sheet1").[b3].CurrentRegion.Columns("z:al")
        .NumberFormat = ""
        .HorizontalAlignment = 1
        .Value = .Value
    End With
End Sub

2) € cost for ID 19 shows 1.708025526 here.
3) Change the inside character set [ADJFMNOS] for first character of each month in Dutch.

Thanks, but you don't need to...

 

[Jacob Petersen]

It is being registered when I run your Sub ConvertToNumber(), but it is still stored as text.

In terms of point 3, then I am not entirely sure what is meant here.

In Danish, the months are the following:
Januar (Jan), Februar (Feb), Marts (Mar), April (Apr), Maj (Maj), Juni (Jun), Juli (Jul), August (Aug), September (Sep), Oktober (Okt), November (Nov), December (Dec).

Hence, should I enter the first character of each month meaning (JFMAMJJASOND) or (JANFEBMARAPRMAJJUNJULAUGSEPOKTNOVDEC)?

Neither is working, so I am sure i misunderstood you

Well, let me know if I can do something at some point.

 

[jindon]

1) I just DL your latest file again and the cells in question are indented to left.
If I format the indent as General, it goes to right, that means Number.
So it might be regional settings problem.

2) Then it should work as it is.
It it doesn't, try change to[
code]
If myDate Like"[0-9]* [!0-9]* [0-9]*"Then[/code]

 

[Jacob Petersen]

I will try to figure out a solution to the regional settings.

Unfortunately

For Each m In .Execute(a(i, ii))
                    myDate = m.submatches(0)
                    If myDate Like "[0-9]* [!0-9]* [0-9]*" Then
                        myDate = CDate(myDate)

did not work either.
However, I can fix the issue with the replace function, that will do.

Once again, thank you for your help Jindon...

 

[jindon]

Ahhh, I missed that you meant,

myDate = CDate(myDate)

Yes, if Maj and Okt are the one differ form Eng, Replace function will be the best.