Transpose columns to rows - First 3 columns same for each row

[CP1127]

Hello-

I have data that is in 2 columns where the Ticket # is in column A and the data from the ticket is in column B. I am trying to write a macro that converts the data to 1 row per request. The caveat is that 1 ticket can have up to 10 requests within it (number of requests vary per ticket). I am able to convert the data into one row per ticket #, but is there a way to convert the data to one row per request? I would like to have the Ticket #, Date, and Invoice # copy onto each row for each request.

This Sample Workbook shows how the data is imported on the first tab and my desired result on the second tab.

Thank you for your time.

 

[MickG]

Try this example file and code below:-
https://app.box.com/s/ffcfvx2eqtls1m3zxmb8ifu783d44kgi

NB:- Results on Sheet2.

[COLOR=navy]Sub[/COLOR] MG19Dec32
[COLOR=navy]Dim[/COLOR] Dn [COLOR=navy]As[/COLOR] Range, Txt [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] a [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dic [COLOR=navy]As[/COLOR] Object
[COLOR=navy]Dim[/COLOR] Q [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]Dim[/COLOR] nTxt [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] k [COLOR=navy]As[/COLOR] Variant, Rw [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] p [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]Dim[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Sp [COLOR=navy]As[/COLOR] Variant, Sp1 [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]Dim[/COLOR] Spr [COLOR=navy]As[/COLOR] Variant, SpR1 [COLOR=navy]As[/COLOR] Variant, nSp [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]With[/COLOR] Sheets("Initial_Data")
    [COLOR=navy]Set[/COLOR] Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
[COLOR=navy]End[/COLOR] With
ReDim ray(1 To Rng.Count, 1 To 8)
 ray(1, 1) = "Ticket": ray(1, 2) = "Date": ray(1, 3) = "Invoice": ray(1, 4) = "#"
 ray(1, 5) = "Company": ray(1, 6) = "Invoice Date": ray(1, 7) = "#": ray(1, 8) = "Comments"
 
 [COLOR=navy]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
            [COLOR=navy]Set[/COLOR] nTxt = Nothing
            Txt = Dn.Offset(, 1).Value
            [COLOR=navy]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR=navy]Then[/COLOR]
                [COLOR=navy]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
            [COLOR=navy]End[/COLOR] If
            Txt = IIf(InStr(Dn.Offset(, 1).Value, "Company") > 0, "Company", Dn.Offset(, 1).Value)
                [COLOR=navy]If[/COLOR] InStr(Dn.Offset(, 1).Value, "Company") > 0 [COLOR=navy]Then[/COLOR]
                    [COLOR=navy]Set[/COLOR] nTxt = Dn.Offset(, 1)
                [COLOR=navy]End[/COLOR] If
                [COLOR=navy]If[/COLOR] Not Dic(Dn.Value).exists(Txt) [COLOR=navy]Then[/COLOR]
                        Dic(Dn.Value).Add (Txt), nTxt
                [COLOR=navy]Else[/COLOR]
                    [COLOR=navy]If[/COLOR] Not nTxt [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                        Set Dic(Dn.Value).Item(Txt) = Union(Dic(Dn.Value).Item(Txt), nTxt) '[COLOR=green][B]Dn.Offset(, 1))[/B][/COLOR]
                    [COLOR=navy]End[/COLOR] If
                [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Dn
  
    c = 1
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] k [COLOR=navy]In[/COLOR] Dic.Keys
       [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Dic(k).Item("Company")
        nSp = Split(Dic(k).Item("Company").Address, ",")
            [COLOR=navy]If[/COLOR] Dn.Address = Range(nSp(UBound(nSp))).Address [COLOR=navy]Then[/COLOR]
                a = a + Dic(k).Item("Company").Count
            [COLOR=navy]End[/COLOR] If
                c = c + 1: ray(c, 1) = k
                [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] p [COLOR=navy]In[/COLOR] Dic(k)
                    Sp = Split(p, " ")
                    Sp1 = Split(p, "=")
                    [COLOR=navy]If[/COLOR] Not Dic(k).Item(p) [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                        Spr = Split(Dn.Value, " ")
                        SpR1 = Split(Dn.Value, "=")
                    [COLOR=navy]End[/COLOR] If
              
               [COLOR=navy]Select[/COLOR] [COLOR=navy]Case[/COLOR] True
                    [COLOR=navy]Case[/COLOR] InStr(p, ")") > 0: ray(c, 2) = Sp(0)
                    [COLOR=navy]Case[/COLOR] InStr(p, "Invoice") > 0:  ray(c, 3) = Sp1(UBound(Sp1))
                    [COLOR=navy]Case[/COLOR] InStr(p, "Company") > 0: ray(c, 4) = Spr(0): ray(c, 5) = SpR1(UBound(SpR1))
                    [COLOR=navy]Case[/COLOR] InStr(p, "Date") > 0: ray(c, 6) = Sp1(UBound(Sp1))
                    [COLOR=navy]Case[/COLOR] InStr(p, "COMPLETE") And a > 0: ray(a + 1, 8) = "COMPLETE": ray(a + 1, 7) = "A"
               [COLOR=navy]End[/COLOR] Select
             
            [COLOR=navy]Next[/COLOR] p
    
    [COLOR=navy]Next[/COLOR] Dn
    [COLOR=navy]Next[/COLOR] k
[COLOR=navy]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 8)
    .Value = ray
    .HorizontalAlignment = xlCenter
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[CP1127]

This worked great, thank you Mick. I know this wasn't an easy task and I really appreciate your help!

 

[MickG]

You're welcome