Macro that transposes and concatenates

[coops711]

Hello

I am trying to write a macro that joins strings of text together whilst also transposing. I'll try provide an example of what I'm after:

So here is table 1, where we write the campaign name, the ad group name and its associated keyword(s).


A B C D

Campaign Name:	Campaign 1	Campaign 2	Campaign 3
Adgroup Name:	Ad group 1	Ad group 2	Ad group 3
Keywords:	Shoes	dresses	towels
	blue shoes	blue dresses	blue towels
			pink towels red towels
What I want is a macro that will assign each keyword with its respective campaign name/ad group, per line, as shown:

<colgroup><col><col><col><col></colgroup><tbody>
</tbody>

A B C

Campaign Name	Adgroup name	Keyword
Campaign 1	Ad group 1	Shoes
Campaign 1	Ad group 1	blue shoes
Campaign 2	Ad group 2	dresses
Campaign 2	Ad group 2	blue dresses
Campaign 3	Ad group 3	towels
Campaign 3	Ad group 3	blue towels
Campaign 3	Ad group 3	pink towels
Campaign 3	Ad group 3	red towels

<colgroup><col><col><col></colgroup><tbody>
</tbody>

Thanks for your help!

 

[Peter_SSs]

Try this in a copy of your workbook.

Sub CampaignDetails()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, r As Long, uba As Long
  
  With Range("A1").CurrentRegion
    a = .Value
    uba = UBound(a)
    ReDim b(1 To Rows.Count, 1 To 3)
    For j = 2 To UBound(a, 2)
      i = 2
      Do
        i = i + 1
        If a(i, j) = "" Then
          i = uba
        Else
          r = r + 1
          b(r, 1) = a(1, j)
          b(r, 2) = a(2, j)
          b(r, 3) = a(i, j)
        End If
      Loop Until i = uba
    Next j
    Application.ScreenUpdating = False
    With .Offset(, .Columns.Count + 1).Resize(, 3)
      .Value = Array("Campaign Name", "Adgroup name", "Keyword")
      .Offset(1).Resize(r).Value = b
      .EntireColumn.AutoFit
    End With
    Application.ScreenUpdating = True
  End With
End Sub

My sample data (A:D) and results (F:H)

Book1
	A	B	C	D	E	F	G	H
1	Campaign Name:	Campaign 1	Campaign 2	Campaign 3		Campaign Name	Adgroup name	Keyword
2	Adgroup Name:	Ad group 1	Ad group 2	Ad group 3		Campaign 1	Ad group 1	Shoes
3	Keywords:	Shoes	dresses	towels		Campaign 1	Ad group 1	blue shoes
4		blue shoes	blue dresses	blue towels		Campaign 2	Ad group 2	dresses
5				pink towels		Campaign 2	Ad group 2	blue dresses
6				red towels		Campaign 3	Ad group 3	towels
7						Campaign 3	Ad group 3	blue towels
8						Campaign 3	Ad group 3	pink towels
9						Campaign 3	Ad group 3	red towels
Campaign

 

[coops711]

Try this in a copy of your workbook.

Sub CampaignDetails()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, r As Long, uba As Long
  
  With Range("A1").CurrentRegion
    a = .Value
    uba = UBound(a)
    ReDim b(1 To Rows.Count, 1 To 3)
    For j = 2 To UBound(a, 2)
      i = 2
      Do
        i = i + 1
        If a(i, j) = "" Then
          i = uba
        Else
          r = r + 1
          b(r, 1) = a(1, j)
          b(r, 2) = a(2, j)
          b(r, 3) = a(i, j)
        End If
      Loop Until i = uba
    Next j
    Application.ScreenUpdating = False
    With .Offset(, .Columns.Count + 1).Resize(, 3)
      .Value = Array("Campaign Name", "Adgroup name", "Keyword")
      .Offset(1).Resize(r).Value = b
      .EntireColumn.AutoFit
    End With
    Application.ScreenUpdating = True
  End With
End Sub

My sample data (A:D) and results (F:H)

	A	B	C	D	E	F	G	H
1	Campaign Name:	Campaign 1	Campaign 2	Campaign 3		Campaign Name	Adgroup name	Keyword
2	Adgroup Name:	Ad group 1	Ad group 2	Ad group 3		Campaign 1	Ad group 1	Shoes
3	Keywords:	Shoes	dresses	towels		Campaign 1	Ad group 1	blue shoes
4		blue shoes	blue dresses	blue towels		Campaign 2	Ad group 2	dresses
5				pink towels		Campaign 2	Ad group 2	blue dresses
6				red towels		Campaign 3	Ad group 3	towels
7						Campaign 3	Ad group 3	blue towels
8						Campaign 3	Ad group 3	pink towels
9						Campaign 3	Ad group 3	red towels

<colgroup><col style="width: 25pxpx"><col><col><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Campaign​

This is great. Thanks - exactly what im looking for. I haven't done a macro like this before.


Could you please help me edit this in the following two ways:

1) I simplified the data slightly to make it easier to read, in the actual sheet there is a gap between the "campaign name" row and the other two rows.

Specifically, the campaign name row is at A14, the ad group name row is at A32, keyword row is at A33

2) Could the data be pasted into a new sheet?

 

[Peter_SSs]

Best not to fully quote long posts as it makes the thread harder to read/navigate and just occupies storage space needlessly. If you want to quote, quote small, relevant parts only.

Could you please help me edit this in the following two ways:

1) I simplified the data slightly to make it easier to read, in the actual sheet there is a gap between the "campaign name" row and the other two rows.

Specifically, the campaign name row is at A14, the ad group name row is at A32, keyword row is at A33

2) Could the data be pasted into a new sheet?

Try this version with a copy of your workbook.

Sub CampaignDetails_v2()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, r As Long, uba As Long, lr As Long
  
  lr = Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, SearchFormat:=False).Row
  a = Range("A14:A" & lr).Resize(, Cells(14, Columns.Count).End(xlToLeft).Column).Value
  uba = UBound(a)
  ReDim b(1 To Rows.Count, 1 To 3)
  For j = 2 To UBound(a, 2)
    i = 19
    Do
      i = i + 1
      If a(i, j) = "" Then
        i = uba
      Else
        r = r + 1
        b(r, 1) = a(1, j)
        b(r, 2) = a(19, j)
        b(r, 3) = a(i, j)
      End If
    Loop Until i = uba
  Next j
  Application.ScreenUpdating = False
  Sheets.Add After:=ActiveSheet
  With Range("A1:C1")
    .Value = Array("Campaign Name", "Adgroup name", "Keyword")
    .Offset(1).Resize(r).Value = b
    .EntireColumn.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub

 

[coops711]

Hi Peter

I will PM you about this if that is OK

Cheers