If cell contains three values (23 + 34 + 12) split them into separate rows

[pitaszek]

Hi Guys,

The example is as follows. Diameter which has more numbers than one needs to be splitten into rows.[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Number[/TD]
[TD]Number2[/TD]
[TD]Name[/TD]
[TD]Diameter[/TD]
[TD]Diameter-total[/TD]
[TD]Some num[/TD]
[/TR]
[TR]
[TD]114[/TD]
[TD]114[/TD]
[TD]Tree1[/TD]
[TD]23 + 45 + 23[/TD]
[TD]91[/TD]
[TD]91[/TD]
[/TR]
[TR]
[TD]115[/TD]
[TD]115[/TD]
[TD]Tree2[/TD]
[TD]24 + 56[/TD]
[TD]80[/TD]
[TD]80[/TD]
[/TR]
[TR]
[TD]116[/TD]
[TD]116[/TD]
[TD]Tree3[/TD]
[TD]23[/TD]
[TD]23[/TD]
[TD]23[/TD]
[/TR]
[TR]
[TD]117[/TD]
[TD]117[/TD]
[TD]Tree4[/TD]
[TD]45[/TD]
[TD]45[/TD]
[TD]45[/TD]
[/TR]
[TR]
[TD]118[/TD]
[TD]118[/TD]
[TD]Tree5[/TD]
[TD]34 + 21 + 90 + 45[/TD]
[TD]190[/TD]
[TD]190[/TD]
[/TR]
</tbody>[/TABLE]

As an example first row (Tree1) would split into the following:
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Number[/TD]
[TD]Number2[/TD]
[TD]Name[/TD]
[TD]Diameter[/TD]
[TD]Diameter-total[/TD]
[TD]Some num[/TD]
[/TR]
[TR]
[TD]114[/TD]
[TD]114[/TD]
[TD]Tree1[/TD]
[TD]23[/TD]
[TD]91[/TD]
[TD]91[/TD]
[/TR]
[TR]
[TD]114[/TD]
[TD]114[/TD]
[TD]Tree1[/TD]
[TD]45[/TD]
[TD]91[/TD]
[TD]91[/TD]
[/TR]
[TR]
[TD]114[/TD]
[TD]114[/TD]
[TD]Tree1[/TD]
[TD]23[/TD]
[TD]91[/TD]
[TD]91[/TD]
[/TR]
</tbody>[/TABLE]

If there is only one value in Diameter column no actions should be taken and for cell with four values, three additional rows should be inserted etc. There might be up to ten values within a cell

For now my code puts empty rows below the rows which have more then 1 value in a diameter field but I have no idea how to split it like presented.

Original file for processing has more than 6 columns.

Sub fd()


Dim last_row As Integer


last_row = Cells(Rows.Count, 1).End(xlUp).Row


For i = 2 To last_row


'take value from column D
an_cell = Range("D" & i).Value


'cont how many pluses are there in a string
Countplus = Len(an_cell) - Len(Replace(an_cell, "+", ""))


'if number of pluses in a string is > 0 then insert additinal rows
If Countplus > 0 Then


    'loop inserting rows
    For j = 1 To Countplus
    Rows(i + 1).Insert
    Sheets(1).Range("A" & i, "AA" & i).Copy
    Sheets(1).Range("A" & i + 1).PasteSpecial xlPasteAll
    Sheets(1).Range("D" & i + 1).ClearContents
    
    Next j


End If


Next i


End Sub

Thanks for your assitance in advance. Happy to anwser any questions related.

Cheers,
Witek

 

[Fluff]

Untested, but try this

Sub SplitOnPlus()

   Dim Cnt As Long
   Dim splt As Long
   
   For Cnt = Range("D" & Rows.Count).End(xlUp).row To 2 Step -1
      If InStr(Range("D" & Cnt), ",") Then
         splt = UBound(Split(Range("D" & Cnt), "+"))
         Rows(Cnt + 1).Resize(splt).Insert
         Rows(Cnt).Resize(splt + 1).FillDown
         Range("D" & Cnt).Resize(splt + 1).Value = Application.Transpose(Split(Range("D" & Cnt), "+"))
         
      End If
   Next Cnt
      
End Sub

 

[pitaszek]

Hi Fluff,

This seems to be working fine! I will do some testing and double confirm that.

I will try to understand the code. May I come with some questions to that?

Regards,
Witek

 

[Fluff]

May I come with some questions to that?

Yea sure