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

I have a EXCEL file w/ 4 fields: 'EmpNum', 'EmpName', 'City Coverage', 'Total Downtime'

 '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 1 city, then that record is copied N times; once for each city.  The output file has 2 additional columns; 'City Total' and 'Avg Downtime'; 'City Total' has the count of cities covered by the employee. 'Avg Downtime' is the computed downtime average for each city.  

The enclosed VBA breaks out each employee w/ each city and works great.  I am not sure how to compute the downtime average, then add it to a new column to the sub-routine.

 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.

Option Explicit

 Sub ReArrangeData()

     Dim swb As Workbook
     Dim dwb As Workbook
     
     Dim sws As Worksheet
     Dim dws As Worksheet
     
     Dim lr As Long
     Dim i As Long
     Dim ii As Long
     Dim j As Long
     Dim 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
Test_Data2.xlsx
vfinatoAsked:
Who is Participating?
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Okay, please give this a try...
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("E2:E" & lr).Formula = "=LEN(C2)-LEN(SUBSTITUTE(C2,"","",""""))+1"
dws.Range("F2:F" & lr).Formula = "=D2/E2"

cnt = Application.Sum(dws.Range("E2:E" & lr))
x = dws.Range("A1").CurrentRegion.Value
ReDim y(1 To cnt, 1 To 5)

For i = 2 To UBound(x, 1)
    If x(i, 5) = 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, 5)
        y(j, 5) = x(i, 6)
    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, 5)
            y(j, 5) = x(i, 6)
        Next ii
    End If
Next i

dws.Range("A1").CurrentRegion.Offset(1).Clear
dws.Range("A2").Resize(UBound(y), 5).Value = y

dws.Range("D1:E1").Value = Array("City Total", "Avg Downtime")
dws.Range("E:E").NumberFormat = "0.0"
dws.UsedRange.Columns.AutoFit
Application.CopyObjectsWithCells = True
Application.ScreenUpdating = True
End Sub

Open in new window

0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
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

Set sws = Sheets("Original")

lr = sws.Cells(Rows.Count, 1).End(xlUp).Row
sws.Range("E2:E" & lr).Formula = "=LEN(C2)-LEN(SUBSTITUTE(C2,"","",""""))+1"
sws.Range("F2:F" & lr).Formula = "=D2/E2"

cnt = Application.Sum(sws.Range("E2:E" & lr))
x = sws.Range("A1").CurrentRegion.Value
ReDim y(1 To cnt, 1 To 5)

For i = 2 To UBound(x, 1)
    If x(i, 5) = 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, 5)
        y(j, 5) = x(i, 6)
    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, 5)
            y(j, 5) = x(i, 6)
        Next ii
    End If
Next i

sws.Range("A1").CurrentRegion.Offset(1).Clear
sws.Range("A2").Resize(UBound(y), 5).Value = y

sws.Range("D1:E1").Value = Array("City Total", "Avg Downtime")
sws.Range("E:E").NumberFormat = "0.0"
sws.UsedRange.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

Open in new window

Test_Data2-v2.xlsm
0
 
vfinatoAuthor Commented:
Neeraj:  The code works great, but it does not put the output into a separate excel file.  I tried putting sms.copy at the very end.  It created an Excel file (Book1.xlsx), but it still had the button and code in it.  

How do I get it to create the output in a separate xlsx excel file?
0
 
vfinatoAuthor Commented:
Neeraj:  Sorry to bother you.  It looks like you added the sws.copy at the beginning of the code.  When I tried that, it copied the data before the update.  That's why I tried moving it to the end, and got the button and code in the output file.  

Anyway, it works great.  Before I close the question, I will need to test it out quite a bit against my data.  

Thank you
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.