• Status: Solved
  • Priority: High
  • Security: Public
  • Views: 60
  • Last Modified:

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
0
vfinato
Asked:
vfinato
  • 3
  • 2
1 Solution
 
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
 
NorieVBA ExpertCommented:
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
Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

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

Join & Write a Comment

Featured Post

Cloud Class® Course: Certified Penetration Testing

This CPTE Certified Penetration Testing Engineer course covers everything you need to know about becoming a Certified Penetration Testing Engineer. Career Path: Professional roles include Ethical Hackers, Security Consultants, System Administrators, and Chief Security Officers.

  • 3
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now