Copy row splitting out text string in one column

[Waspeze]

Hi, had some great help here before so hopefully someone can help with this..

I have a file with potentially 10's of thousands of rows. In each row there is a field called "Country Responsible" and in this there can be one or more countries in the same cell separated by " - ".

What I need is if, for example, there are two countries, say UK - FRANCE, then a new row inserted below with all the same data except in the country responsible field the original cell shows UK and the one below shows FRANCE

I've attached a workbook with two sheets, the first one "Start" shows how the data comes to me and the second one "End" shows how I would like it to end up.

I'd be very grateful for help with a macro that can do this.. note that the resulting data can either be on the original sheet but adjusted for the result i'm after or on a new sheet, I have no preference!

Thanks in advance

[jindon]

Try

Sub test()
    Dim a, b, x, e, i As Long, ii As Long, n As Long
    a = Sheets("start").Cells(1).CurrentRegion.Value
    ReDim b(1 To Rows.Count, 1 To UBound(a, 2) + 1)
    b(1, UBound(b, 2)) = "Percent"
    For i = 1 To UBound(a, 1)
        If a(i, 3) <> "" Then
            x = Split(a(i, 3), "-")
            For Each e In x
                n = n + 1
                For ii = 1 To UBound(a, 2)
                    b(n, ii) = a(i, ii)
                Next
                b(n, 3) = Trim$(e)
                If n > 1 Then b(n, UBound(b, 2)) = 1 / (UBound(x) + 1)
            Next
        End If
    Next
    With Sheets("end").Cells(1).Resize(n, UBound(b, 2))
        .CurrentRegion.ClearContents
        .Columns(1).NumberFormat = "@"
        .Value = b: .Columns.AutoFit
    End With
End Sub

[Waspeze]

Try

Seems to work perfectly... thanks loads jindon!! Very much appreciated!

[Glenn Kennedy]

I just noticed that you want a macro. Blast!!! Here's a formula. Give it a go!!

helper in start F2, copied down:
=LEN(C2)-LEN(SUBSTITUTE(C2,"-",""))+1

End, A2 copied across to E2 and then down:
=IFERROR(INDEX(Start!A$2:A$26,MATCH(0,INDEX(--(COUNTIF(A$1:A1,Start!A$2:A$26)=Start!$F$2:$F$26),0),0)),"")

Overtype this into C2 and copy down:
=IFERROR(TRIM(MID(SUBSTITUTE("-"&INDEX(Start!C$2:C$26,MATCH(0,INDEX(--(COUNTIF($A$1:$A1,Start!$A$2:$A$26)=Start!$F$2:$F$26),0),0)),"-",REPT(" ",125)),125*COUNTIF($A$2:$A2,$A2),125)),"")

[Waspeze]

I just noticed that you want a macro. Blast!!! Here's a formula. Give it a go!!

helper in start F2, copied down:
=LEN(C2)-LEN(SUBSTITUTE(C2,"-",""))+1

End, A2 copied across to E2 and then down:
=IFERROR(INDEX(Start!A$2:A$26,MATCH(0,INDEX(--(COUNTIF(A$1:A1,Start!A$2:A$26)=Start!$F$2:$F$26),0),0)),"")

Overtype this into C2 and copy down:
=IFERROR(TRIM(MID(SUBSTITUTE("-"&INDEX(Start!C$2:C$26,MATCH(0,INDEX(--(COUNTIF($A$1:$A1,Start!$A$2:$A$26)=Start!$F$2:$F$26),0),0)),"-",REPT(" ",125)),125*COUNTIF($A$2:$A2,$A2),125)),"")

Thanks for your help Glenn.. I do prefer it in a macro but if I ever change the process to a formula i'll come back to this!

[kvsrinivasamurthy]

Here is the code for macro

Sub Macro1()
Dim TA As Long, T As Long, K As Integer

Sheets("Start").Activate
Application.ScreenUpdating = False

T = 2

Do While Range("A" & T) <> ""
K = Len(Range("C" & T)) - Len(Replace(Range("C" & T), "-", ""))
    
    If K > 0 Then
    M = Split(Range("C" & T), "-")
    Range("A" & T + 1 & ":A" & T + K).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
        For TA = 0 To K
        Range("A" & T & ":E" & T).Copy Range("A" & T + K & ":E" & T + K)
        Range("C" & T + TA) = Trim(M(TA))
        Range("F" & T + TA) = 1 / (K + 1)
        Next TA
    End If

T = T + K + 1
   
Loop
Application.ScreenUpdating = True

End Sub