Read EXCEL records, parse, and copy to new EXCEL file

I have a EXCEL file w/ 3 fields: "Emp-Num", "Emp-Name", "City Coverage"

"City Coverage" has 1 to many names of cities covered by an employee.  If more than 1 city, the cities are separated by a comma.  I need to copy each record to another EXCEL file.  If an employee covers more than city, then that record is copied N times; once for each city.  The output file has an additional column; "City Total", which has the count of cities covered by the employee.  

I am very familiar w/ VBA, but have not used VBA w/ EXCEL.  Please help. Thank you, very much. Enclosed, is an EXCEL file w/ 2 tabs:  "Original" shows the data.  "Final" shows what the data needs to look like when completed.Test_Data1.xlsx
vfinatoAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You may try something like this...
In the attached, click the button called "Copy To New File" on Original Sheet to run the code.

Sub ReArrangeData()
Dim swb As Workbook, dwb As Workbook
Dim sws As Worksheet, dws As Worksheet
Dim lr As Long, i As Long, ii As Long, j As Long, cnt As Long
Dim x, y()
Dim str() As String

Application.ScreenUpdating = False
Application.CopyObjectsWithCells = False
Set swb = ThisWorkbook
Set sws = swb.Sheets("Original")

sws.Copy
Set dwb = ActiveWorkbook
Set dws = dwb.Sheets(1)

lr = dws.Cells(Rows.Count, 1).End(xlUp).Row
dws.Range("D2:D" & lr).Formula = "=LEN(C2)-LEN(SUBSTITUTE(C2,"","",""""))+1"
cnt = Application.Sum(dws.Range("D2:D" & lr))
x = dws.Range("A1").CurrentRegion.Value
ReDim y(1 To cnt, 1 To 4)

For i = 2 To UBound(x, 1)
    If x(i, 4) = 1 Then
        j = j + 1
        y(j, 1) = x(i, 1)
        y(j, 2) = x(i, 2)
        y(j, 3) = x(i, 3)
        y(j, 4) = x(i, 4)
    Else
        str = Split(x(i, 3), ",")
        For ii = 0 To UBound(str)
            j = j + 1
            y(j, 1) = x(i, 1)
            y(j, 2) = x(i, 2)
            y(j, 3) = Trim(str(ii))
            y(j, 4) = x(i, 4)
        Next ii
    End If
Next i

dws.Range("A1").CurrentRegion.Offset(1).Clear
dws.Range("A2").Resize(UBound(y), 4).Value = y
dws.Range("D1").Value = "City Total"
dws.Range("A1").CurrentRegion.Borders.Color = vbBlack
dws.UsedRange.Columns.AutoFit
Application.CopyObjectsWithCells = True
Application.ScreenUpdating = True
End Sub

Open in new window

Test_Data1.xlsm
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
NorieAnalyst Assistant Commented:
Here's my version.
Sub DrillDown()
Dim wsFinal As Worksheet
Dim arrIn As Variant
Dim arrOut() As Variant
Dim arrCities As Variant
Dim I As Long
Dim J As Long
Dim K As Long
Dim cnt As Long

    arrIn = Sheets("Original").Range("A1").CurrentRegion
    
    For I = LBound(arrIn) + 1 To UBound(arrIn)
        arrCities = Split(arrIn(I, 3), ",")
        
        For J = LBound(arrCities) To UBound(arrCities)
            cnt = cnt + 1
            ReDim Preserve arrOut(1 To 3, 1 To cnt)
            
            For K = LBound(arrIn, 2) To UBound(arrIn, 2) - 1
                arrOut(K, cnt) = arrIn(I, K)
            Next K
            arrOut(K, cnt) = Trim(arrCities(J))
        Next J
    Next I
    
    Set wsFinal = Sheets.Add
    
    With wsFinal
        .Rows(1).Value = Sheets("Original").Rows(1).Value
        With .Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
            .Value = "City Total"
            .Offset(1).Resize(UBound(arrOut, 2)).FormulaR1C1 = "=COUNTIF(R2C1:R" & UBound(arrOut, 2) - 1 & "C1,RC1)"
        End With
        .Range("A2").Resize(UBound(arrOut, 2), UBound(arrOut, 1)).Value = Application.Transpose(arrOut)
        
    End With
    
End Sub

Open in new window

0
vfinatoAuthor Commented:
Neeraj:  Thank you for your solution.  I would like to put the button on a separate sheet, and have the input data on it's own sheet.  I am trying to understand how to do that.
0
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome vfinato!

In that case, please try this...

Sub ReArrangeData()
Dim sws As Worksheet
Dim lr As Long, i As Long, ii As Long, j As Long, cnt As Long
Dim x, y()
Dim str() As String

Application.ScreenUpdating = False
Application.CopyObjectsWithCells = False

Set sws = Sheets("Original")

lr = sws.Cells(Rows.Count, 1).End(xlUp).Row
sws.Range("D2:D" & lr).Formula = "=LEN(C2)-LEN(SUBSTITUTE(C2,"","",""""))+1"
cnt = Application.Sum(sws.Range("D2:D" & lr))
x = sws.Range("A1").CurrentRegion.Value
ReDim y(1 To cnt, 1 To 4)

For i = 2 To UBound(x, 1)
    If x(i, 4) = 1 Then
        j = j + 1
        y(j, 1) = x(i, 1)
        y(j, 2) = x(i, 2)
        y(j, 3) = x(i, 3)
        y(j, 4) = x(i, 4)
    Else
        str = Split(x(i, 3), ",")
        For ii = 0 To UBound(str)
            j = j + 1
            y(j, 1) = x(i, 1)
            y(j, 2) = x(i, 2)
            y(j, 3) = Trim(str(ii))
            y(j, 4) = x(i, 4)
        Next ii
    End If
Next i

sws.Range("A1").CurrentRegion.Offset(1).Clear
sws.Range("A2").Resize(UBound(y), 4).Value = y
sws.Range("D1").Value = "City Total"
sws.UsedRange.Columns.AutoFit
Application.CopyObjectsWithCells = True
Application.ScreenUpdating = True
End Sub

Open in new window

Test_Data-v2.xlsm
0
vfinatoAuthor Commented:
Neeraj:  I think I figured it out.  I would like the button on its own separate sheet, the input data on its own separate sheet and the output going to its own excel file, like you did in the original version.  It looks like all I need to do is move the button to its own sheet and point the button object to the ReArrangeData Macro.

If I could ask.  I am trying to understand the code.  It looks like swb and sws point to the "Original" workbook and worksheet. And, dwb and dws point to the new workbook and worksheet.  The question is why do you ReDim cnt 1 to 4.  Is that because there are 4 columns in the dws worksheet?
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
That's correct. 1 to 4 because there would be 4 columns finally in the resultant data set.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Office

From novice to tech pro — start learning today.