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

'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

Application.CopyObjectsWit

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(C

cnt = Application.Sum(dws.Range(

x = dws.Range("A1").CurrentReg

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").CurrentReg

dws.Range("A2").Resize(UBo

dws.Range("D1").Value = "City Total"

dws.Range("A1").CurrentReg

dws.UsedRange.Columns.Auto

Application.CopyObjectsWit

Application.ScreenUpdating

End Sub

Test_Data2.xlsx

```
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
```

Test_Data2-v2.xlsm
How do I get it to create the output in a separate xlsx excel 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

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.

Open in new window