Adding rows based on comma value

smashclash

Board Regular
Joined
Nov 24, 2003
Messages
125
Office Version
365
Platform
Windows
I have a set of data like below that I need to separate out. Rather than the data be broken out for each single instance of a name it's grouped together at times and summed the amt. So for example in the below picture I'd like Chip Dale and Vicky Micky to be in separate rows and each have an amount of $500. VBA could identify the need to break this out because of the comma in column A. Frank Tank in A3 would be no action since there are no commas. Chip Dale, Vicky Micky, Mike Ike in A5 would need two rows added and the 800 divided by 3 (266.67) since there are three names for the Amt.

For all the rows with commas the names should only appear one time after VBA runs. So it could work as follows. Search column A for a comma. FInd comma and insert the number of rows equivalent to the number of commas. Then adjust the Names so they only appear once. Example, search column A for comma, find one in Column A2. Clone row 2. Change name in row A2 to Chip Dale and amount to be 500. The new row added would be Vicky Micky and Amt is 500. Then repeat for any other commas in column A.



Names.PNG
 

Some videos you may like

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.

sandy666

Well-known Member
Joined
Oct 24, 2015
Messages
4,676
like this?
NameAmtNameAmt
Chip Dale, Vicky Micky1,000.00Chip Dale500
Frank Tank300.00Vicky Micky500
Mitch Bub200.00Frank Tank300
Chip Dale, Vicky Micky, Mike Ike800.00Mitch Bub200
Larry Link5,000.00Chip Dale266.67
Vicky Micky266.67
Mike Ike266.67
Larry Link5000

with Power Query (Get&Transfrom)
Code:
// Table1
let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    Count = Table.AddColumn(Source, "Count", each List.Count(Text.Split([Name],","))),
    TSC = Table.SelectColumns(Table.TransformColumns(Table.AddColumn(Count, "Division", each [Amt] / [Count], type number),{{"Division", each Number.Round(_, 2), type number}}),{"Name", "Division"}),
    Split = Table.ExpandListColumn(Table.TransformColumns(TSC, {{"Name", Splitter.SplitTextByDelimiter(", ", QuoteStyle.Csv), let itemType = (type nullable text) meta [Serialized.Text = true] in type {itemType}}}), "Name"),
    Result = Table.RenameColumns(Split,{{"Division", "Amt"}})
in
    Result
 
Last edited:

kweaver

Well-known Member
Joined
May 8, 2018
Messages
922
Office Version
365, 2010
Amateur VBA which surely will be improved upon (but my first criteria is to get it to work!):

Code:
Sub Split_Share()
Dim LR As Long, com As Integer, i As Integer, r As Integer, name As String, nc As Integer
LR = Range("A" & Rows.Count).End(xlUp).Row
r = 2
For i = 2 To LR
name = Range("A" & i)
nc = 1 + Len(name) - Len(Replace(name, ",", ""))
name = name & ","
While Len(name) <> 0
com = InStr(name, ",")
    If com > 0 Then
      Cells(r, 3) = Left(name, com - 1)
      Cells(r, 4) = Range("B" & i) / nc
      r = r + 1
      name = Right(name, Len(name) - com)
    Else
      Cells(r, 3) = Cells(i, 1)
      Cells(r, 4) = Cells(i, 2)
      r = r + 1
End If
Wend
Next
End Sub
 

GWteB

Active Member
Joined
Sep 10, 2010
Messages
423
Office Version
2013
Platform
Windows
.... and another approach ...
VBA Code:
Public Sub Example()

    Dim oWs     As Worksheet
    Dim oRng    As Range
    Dim lRows   As Long
    Dim i       As Long
    Dim n       As Integer
    Dim cyAmt   As Currency
    Dim vNames  As Variant

    Set oWs = ActiveSheet

    With oWs
        lRows = .Range("A" & .Rows.Count).End(xlUp).Row
        For i = lRows To 2 Step -1
            Set oRng = .Range("A" & i)
            With oRng
            vNames = Split(.Text, ",")
                If UBound(vNames) > 0 Then
                    n = 0
                    cyAmt = .Offset(0, 1).Value / (UBound(vNames) + 1)
                    .Value = vNames(n)
                    .Offset(0, 1).Value = cyAmt
                    For n = 1 To UBound(vNames)
                        .Offset(n, 0).EntireRow.Insert
                        .Offset(n, 0).Value = Trim(vNames(n))
                        .Offset(n, 1).Value = cyAmt
                    Next n
                End If
            End With
        Next i
    End With
    Set oRng = Nothing
    Set oWs = Nothing
End Sub
 

kweaver

Well-known Member
Joined
May 8, 2018
Messages
922
Office Version
365, 2010
I change this line
Code:
name = Right(name, Len(name) - com)
to

[code'
name = TRIM(Right(name, Len(name) - com))[/code]
 

smashclash

Board Regular
Joined
Nov 24, 2003
Messages
125
Office Version
365
Platform
Windows
Thanks everyone. I was hoping I could take the code posted and modify it to fit my needs but I just don't understand VBA enough yet. There's some additional data in other columns within the row I would like to copy down as well. Let's assume it's in column C-Z. How should the VBA from GWteB be tweaked? Column A and B would be the only ones that might get changed due to the criteria in Column A.
 

sandy666

Well-known Member
Joined
Oct 24, 2015
Messages
4,676
Answer is tailored to your question (post#1)
Post representative example
 

kweaver

Well-known Member
Joined
May 8, 2018
Messages
922
Office Version
365, 2010
You'll have to provide more information about the other cells and how they relate to column A
 

kweaver

Well-known Member
Joined
May 8, 2018
Messages
922
Office Version
365, 2010
If you have the names in column A and amount 1 in column B and amount 2 in column C, this will split them, according to your original explanation, into columns E, F, and G, respectively.
Code:
Sub Split_Share()
Dim LR As Long, com As Integer, i As Integer, r As Integer, name As String, nc As Integer
LR = Range("A" & Rows.Count).End(xlUp).Row
r = 2
For i = 2 To LR
name = Range("A" & i)
name = name & ","
nc = Len(name) - Len(Replace(name, ",", ""))
While Len(name) <> 0
com = InStr(name, ",")
    If com > 0 Then
      Cells(r, 5) = Left(name, com - 1)  ' put individual names in column E
      Cells(r, 6) = Range("B" & i) / nc  ' split the amounts and put in column F     
      Cells(r, 7) = Range("C" & i) / nc ' split contents of  C into column G
      ' assuming it is also money, and divide it up accordingly
      r = r + 1
      name = Trim(Right(name, Len(name) - com))
    Else
      Cells(r, 5) = Cells(i, 1)
      Cells(r, 6) = Cells(i, 2)
      Cells(r, 7) = Cells(i, 3)
      r = r + 1
      r = r + 1
End If
Wend
Next
End Sub
 

smashclash

Board Regular
Joined
Nov 24, 2003
Messages
125
Office Version
365
Platform
Windows
OK here is a snippet of the full report. Sorry for not just posting this to begin with. I thought it would be easier to understand what I wanted by only citing the "moving parts" to my problem.

The actual report contains many more rows but all the columns are here on the report I want to modify with VBA. The variable for the SalesReps names are in column AE. The amount that would be divided based on the number of Sales Reps names is Column T (Actual_Amount). What I want to do is for all rows that have multiple sales reps, clone the row with the multiple sales rep by adding a line below it and then dividing (the Actual_Amount) column T by the number of sales reps in Column AE. Then have those multiple sales reps represented only one time. So for example in the below report in cell AE9 there are 3 sales reps listed. I need row 9 to be cloned two times (because there are 3 names in it), then have the names in AE be: Chris Pilgrim in a row, Chris Tophe in the next row, and Lauren Lilly in the last row. The amount from Column T would then be divided by 3 (for the 3 Sales reps names) so it would go from $13,500 to $4,500. I'd like all the data in the other columns to be copied from the original row.



Weekly Example.xlsx
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKALAMANAOAPAQARASATAUAVAWAXAYAZBABBBCBDBEBFBGBHBIBJBKBLBMBNBOBPBQBR
1YearGroupBrandProduct LineIDAdvertiser_IDAdvertiser_NameBrand_IDBrand_NameLine_IDWebsite_IDStart_DateEnd_DateLineTypeCurrency_CodeRateEstimated_QtyEstimated_AmountActual_QtyActual_AmountIs_RONQty_ServedQty_Server_AsOfAuditStampWebsite_NameExternal_IDExternal_OrderIDAgency_NameStatusLineDescriptionSalesRepsIsNewsletterEstimatedNetActualNetFCEstimatedNetFCActualNetFCEstimatedAmountFCActualAmountProposalIDContractIDSizesRONWebsiteIDRONWebsiteNameSectionIDSectionNamePositionIDPositionNameHasPrePaymentCampaignTypeGLTypeIDGLTypeNameTrackingCurrenciesRatecardRateMaterialStatusCodeAdTypeIDAdTypeNameProductionControllerIDProductionControllerNameCampaignTypeDescriptionTCEstimatedNetTCActualNetTCEstimatedAmountTCActualAmountToolTipSelectedAdServerIDThirdPartyIDFourthPartyIDUDFAnswersCampaignDescription
22020 YTDPromoPromoLive Event100102434GilbertXXGilbert2511004090111/1/2019########FFUSD595016703.21 6,703.20 FALSE01.89186E+12Promo DCISStandard SponsorshipVicky MickyTRUE6703.26703.26703.26703.26703.26703.2Standard SponsorshipFALSEF1221SponsorshipsSystem.Collections.Generic.List`1[Elan.Library.Ad.Internet.OrdersByWebsite+TrackingCurrency]595023SponsorshipsN.SupportN.SupportFlexible0000FALSESystem.Collections.Generic.List`1[System.String]MM.9921
32020 YTDPromoPMVideo1002102590KTIXXKTI51931024040111/1/2019########FFUSD50015001 500.00 FALSE01.89684E+12PM VideoISProduct VideoJesse Coat, Vicky MickyTRUE500500500500500500Product VideoFALSEF1620VideoSystem.Collections.Generic.List`1[Elan.Library.Ad.Internet.OrdersByWebsite+TrackingCurrency]5000013Video-Flat FeeN.SupportN.SupportFlexible0000FALSESystem.Collections.Generic.List`1[System.String]Product Video Series 1
42020 YTDPromoPMVideo1002102590KTIXXKTI51941024040111/1/2019########FFUSD50015001 500.00 FALSE01.89684E+12PM VideoISProduct VideoJesse Coat, Vicky MickyTRUE500500500500500500Product VideoFALSEF1620VideoSystem.Collections.Generic.List`1[Elan.Library.Ad.Internet.OrdersByWebsite+TrackingCurrency]5000013Video-Flat FeeN.SupportN.SupportFlexible0000FALSESystem.Collections.Generic.List`1[System.String]Product Video Series 1
52020 YTDPromoPMVideo1002102590KTIXXKTI51951024040111/1/2019########FFUSD50015001 500.00 FALSE01.89684E+12PM VideoISProduct VideoJesse Coat, Vicky MickyTRUE500500500500500500Product VideoFALSEF1620VideoSystem.Collections.Generic.List`1[Elan.Library.Ad.Internet.OrdersByWebsite+TrackingCurrency]5000013Video-Flat FeeN.SupportN.SupportFlexible0000FALSESystem.Collections.Generic.List`1[System.String]Product Video Series 1
62020 YTDPromoPMVideo1002102590KTIXXKTI51961024040111/1/2019########FFUSD50015001 500.00 FALSE01.89684E+12PM VideoISProduct VideoJesse Coat, Vicky MickyTRUE500500500500500500Product VideoFALSEF1620VideoSystem.Collections.Generic.List`1[Elan.Library.Ad.Internet.OrdersByWebsite+TrackingCurrency]5000013Video-Flat FeeN.SupportN.SupportFlexible0000FALSESystem.Collections.Generic.List`1[System.String]Product Video Series 1
72020 YTDTMNPPVideo1015102319SoftwareXXSoftware52591021040111/1/2019########FFUSD5500155001 5,500.00 FALSE01.89684E+12NPP VideoISTestimonial VideoChris TopheTRUE550055005500550055005500Testimonial VideoFALSEM1620VideoSystem.Collections.Generic.List`1[Elan.Library.Ad.Internet.OrdersByWebsite+TrackingCurrency]5000013Video-Flat FeeN.SupportN.SupportPerformance0000FALSESystem.Collections.Generic.List`1[System.String]
82020 YTDPrintPIPrint1016103217CopierA1Copier52651001030111/15/2019########FFUSD4500145001 4,500.00 FALSE01.90013E+12PI the MagWavemaker GlobalISFull Page Chris PilgrimFALSE450045004500450045004500Full Page FALSEM1001PrintSystem.Collections.Generic.List`1[Elan.Library.Ad.Internet.OrdersByWebsite+TrackingCurrency]78751ROPN.SupportN.SupportPerformance0000FALSESystem.Collections.Generic.List`1[System.String]Fall Advertising
92020 YTDPrintPKILive Event1017106975SignificantXXSignificant52671025090111/8/2019########FFUSD135001135001 13,500.00 FALSE01.89684E+12PKI DPSISSilver SponsorshipChris Pilgrim, Chris Tophe, Lauren LillyTRUE135001350013500135001350013500Silver SponsorshipTRUEF1221SponsorshipsSystem.Collections.Generic.List`1[Elan.Library.Ad.Internet.OrdersByWebsite+TrackingCurrency]1350023SponsorshipsN.SupportN.SupportFlexible0000FALSESystem.Collections.Generic.List`1[System.String]
102020 YTDPrintPKILive Event1017106975SignificantXXSignificant52681025090111/8/2019########FFUSD1000110001 1,000.00 FALSE01.89684E+12PKI DPSISSponsor Additional Staff BadgeChris PilgrimTRUE100010001000100010001000Sponsor Additional Staff BadgeTRUEF1221SponsorshipsSystem.Collections.Generic.List`1[Elan.Library.Ad.Internet.OrdersByWebsite+TrackingCurrency]250023SponsorshipsN.SupportN.SupportFlexible0000FALSESystem.Collections.Generic.List`1[System.String]
112020 YTDPrintPKILive Event1017106975SignificantXXSignificant52721025090111/8/2019########FFUSD35013501 350.00 FALSE01.89684E+12PKI DPSISGolf - Play GolfChris Pilgrim, Chris Tophe, Lauren LillyTRUE350350350350350350Golf - Play GolfTRUEF1221SponsorshipsSystem.Collections.Generic.List`1[Elan.Library.Ad.Internet.OrdersByWebsite+TrackingCurrency]35023SponsorshipsN.SupportN.SupportFlexible0000FALSESystem.Collections.Generic.List`1[System.String]
Sheet1
 

Forum statistics

Threads
1,089,515
Messages
5,408,740
Members
403,224
Latest member
rholmesa

This Week's Hot Topics

  • help please
    SORRY NOT ANY GOOD AT EXCEL SO HELP WOULD BE MUCH APPRECIATED this formula is in a sheet called ignore...
  • two formulas needed
    Hello, I'll try my best to explain this: First formula needed in Sheet1 cell A2: If Sheet1 cell B2 = Sheet2 cell B2 then return a 1. If not then...
  • Dynamic Counts
    Good afternoon, we are tidying up some data & the data seems to be growing quicker than we are tidying it up! What we confirm (by reviewing it...
  • Help Excel formula eliminate duplicate values and keep only 2 identical rows.
    as picture below column A has a duplicate value. but the values are not the same as the rule. sometimes 4 rows, sometimes 10 rows or 7 or 9...
  • Macro Compile Error Sub or Function not defined
    Hello, I am trying to run macros from a validation list, all macros have been created and run perfectly on there own but I'm getting a compile...
  • Last row combined with Current Region VBA
    I'm generally happy finding the last row of data through something like Lastrow = Cells(Rows.Count, "D").End(xlUp) but I don't always receive data...
Top