asked on

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

ASKER CERTIFIED SOLUTION

Subodh Tiwari (Neeraj)

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Norie

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

Vince

ASKER

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.

Subodh Tiwari (Neeraj)

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

Vince

ASKER

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?

Subodh Tiwari (Neeraj)

That's correct. 1 to 4 because there would be 4 columns finally in the resultant data set.