Thread: VBA Script to create new rows based on delimited data

Hello everyone, I am new to the forum here. Glad to be a member - there seems to be a lot of very knowledgable members here!

As a quick intro, I run a small telecommunications business and do quite a bit of data manipulation involving long distance rates.

I get data in different formats from different providers and I always import the data to excel where I will change the fields around and format it exactly as my billing software expects it.

The data I got from my latest provider is proving to be quite the challenge to get formatted correctly. I think I need a simple VBA script to do the job for me, but I have no experience at all in VBA scripting. I would greatly appreciate if someone could point me in the right direction for what I am trying to accomplish.

Now, here is the problem:

I need my destination prefix data as a single number. The rest of the data is irrelevant for this problem but in case it will help here is the important data I need formatted:

| dial prefix | destination name | sell rate | buy rate |

Usually I get data in the format of:

| country | prefix | rate | name |
| 1 | 416 | 0.001 | Canada |
| 1 | 514 | 0.001 | Canada |

This would be no problem as I can just merge the country number with the prefix to get something like:

=B1&B2

| dialprefix | name | rate |
| 1416 | Canada | 0.001 |
| 1514 | Canada | 0.001 |

My latest provider really though me for a loop with this kind of data:

| country | prefix | rate | name |
| 1 | 416&905&647 | 0.001 | Canada |
| 1 | 514&289 | 0.001 | Canada |

Some of my international destinations have anywhere from 2 to 250+ of seperate prefixs seperated by "&" signs in a single cell. I have to have a single dialprefix on each row, so for each entry that has a prefix with 1 or more & signs I need to seperate this data and copy it to a new row. I have figured out how to seperate all the prefixes using the Text to Columns function, but this would still require a ton of manual work to keep inserting rows and then one at a time copying the prefixes in.

In case I am not being clear enough, I will give a very clear example again:
I also attached a small sample of Chile rates that have quite a bit of "&" seperated prefixes.

Afghanistan:

Afghanistan 0.23 93 70
Afghanistan 0.2272 93 79
Afghanistan 0.2255 93 7502&7503&7500&7501&7504


I would instead need:

Afghanistan 0.23 93 70
Afghanistan 0.2272 93 79
Afghanistan 0.2255 93 7502
Afghanistan 0.2255 93 7503
Afghanistan 0.2255 93 7500
Afghanistan 0.2255 93 7501
Afghanistan 0.2255 93 7504

If anyone could guide me in the right direction, or hopefully already have a similar VBA script done - that would be of great assistance! And maybe I could help you get better long distance rates as well

Thanks,

Aaron
PirayaTel
www.piraya.com

aaronic,

Welcome to the forum!

Give this code a try:

Sub tgr()
    
    Dim arrData() As Variant
    Dim strTemp() As String
    Dim rngD As Range, DCell As Range
    Dim arrMax As Long, r As Long, c As Long, strIndex As Long
    
    Set rngD = Range("D2", Cells(Rows.Count, "D").End(xlUp))
    arrMax = Evaluate("=SUMPRODUCT(LEN(" & rngD.Address & ")-LEN(SUBSTITUTE(" & rngD.Address & ",""&"",""""))+1)")
    ReDim arrData(1 To arrMax, 1 To 6)
    
    For Each DCell In rngD
        If InStr(DCell.Text, "&") > 0 Then
            strTemp = Split(DCell.Text, "&")
            For strIndex = LBound(strTemp) To UBound(strTemp)
                r = r + 1
                For c = 1 To 6
                    If c = 4 Then
                        arrData(r, c) = strTemp(strIndex)
                    Else
                        arrData(r, c) = Cells(DCell.Row, c).Value
                    End If
                Next c
            Next strIndex
        Else
            r = r + 1
            For c = 1 To 6
                arrData(r, c) = Cells(DCell.Row, c).Value
            Next c
        End If
    Next DCell
    
    Range("A2:F2").Resize(arrMax).Value = arrData
    
End Sub