VBA: Transpose & CONCATENATE

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
149
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
Hi. I have this sheet that I want to transpose into an easier to read format. I don't know how to write a VBA code for each. I can write a CONCATENATE formula but prefer a simple VBA code that I can adjust later if required, as I'm a noob.
Thank you for your help.

ABCDEFGHI
HEADER1pr#PR NAMEPMDEADLINEHEADER6HEADER7HEADER8HEADER9
123Sample1NAME125-Dec-20
234Sample2NAME126-Dec-20
345Sample3NAME127-Dec-20
456Sample4NAME228-Dec-20
457Sample5NAME329-Dec-20
458Sample6NAME430-Dec-20
459Sample7NAME531-Dec-20
460Sample8NAME31-Jan-21
461Sample9NAME42-Jan-21
462Sample10NAME53-Jan-21
SHEET 2


TO this table below.
Each Cell below the headers will have:
Date
PR#
PR NAME

ABCDEFGH
NAME1NAME2NAME3NAME4NAME5NAME6NAME7NAME8
CONCATENATE
12/25/2020 PR#123 PR NAME12/28/2020 PR#456 PR NAME
SHEET1
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
149
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
So I found this snippet of code from Ombir Transpose and Concatenate Personnel numbers in VBA
How do I modify it to suit my needs? I'm not entirely sure it will work for me.

VBA Code:
Function Merge(rng As Range) As String
    Dim ar As Variant
    ar = Application.Transpose(rng)
    Merge = Join(ar, ", ")
End Function
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,511
Office Version
  1. 365
Platform
  1. Windows
Could you show the full expected results for NAME1, NAME2 and NAME3?
 

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
149
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
Could you show the full expected results for NAME1, NAME2 and NAME3?
Hello Peter. Thanks for taking a look at my request.
As you had requested, below is the full expected results for NAME#....
Hope that helps.

Currently, I have to manually enter a code in each cell to CONCATENATE what I need and it's taking forever. Then manually finding the next NAME# in the list. It's no wonder I need glasses now haha.
eg.
Excel Formula:
=CONCATENATE(TEXT(E23, "mm/dd/yyyy"),CHAR(10),B23,CHAR(10),D23,CHAR(10),C23,CHAR(10))

Expected Results
ABCDEFGH
NAME1NAME2NAME3NAME4NAME5NAME6NAME7NAME8
12/23/2020 123 Sample1 12/26/2020 456 Sample4 12/27/2020 457 Sample5 12/28/2020 458 Sample6 12/29/2020 459 Sample7
12/24/2020 234 Sample2 12/30/2020 460 Sample8 12/31/2020 461 Sample9 01/01/2021 462 Sample10
12/25/2020 345 Sample3
SHEET1


Taken From this:
ABCDEFGHI
HEADER1pr#PR NAMEPMDEADLINEHEADER6HEADER7HEADER8HEADER9
123Sample1NAME112/23/2020
234Sample2NAME112/24/2020
345Sample3NAME112/25/2020
456Sample4NAME212/26/2020
457Sample5NAME312/27/2020
458Sample6NAME412/28/2020
459Sample7NAME512/29/2020
460Sample8NAME312/30/2020
461Sample9NAME412/31/2020
462Sample10NAME51/1/2021
SHEET 2
 
Last edited:

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,511
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

As you had requested, below is the full expected results
Hmm, those dates don't seem to bear much resemblance to the sample data given earlier and also now there appears to be 4 items in each cell instead of 3.

Anyway, see if this helps. It assumes that Sheet1 already exists but has nothing in it.

VBA Code:
Sub Rearrange()
  Dim a As Variant, b As Variant, cr As Variant
  Dim d As Object
  Dim i As Long, lr As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  With Sheets("Sheet2")
    lr = .Range("B" & Rows.Count).End(xlUp).Row
    a = Application.Index(.Cells, Evaluate("row(2:" & lr & ")"), Array(5, 2, 4, 3))
  End With
  ReDim b(1 To UBound(a), 1 To UBound(a))
  For i = 1 To UBound(a)
    If Not d.exists(a(i, 3)) Then d(a(i, 3)) = d.Count + 1 & " 1"
    cr = Split(d(a(i, 3)))
    b(cr(1), cr(0)) = Format(a(i, 1), "mm/dd/yyyy") & vbLf & Join(Application.Index(a, i, Array(2, 3, 4)), vbLf)
    d(a(i, 3)) = cr(0) & " " & cr(1) + 1
  Next i
  With Sheets("Sheet1")
    With .Range("A2").Resize(UBound(a), d.Count)
      .WrapText = True
      .Value = b
      .Rows(0).Value = d.Keys
    End With
  End With
End Sub
 
Solution

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
149
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
You are quick. I was not expecting any answer tonight. Thank you so much for your quick response!!
Yeah, I had to re-create it because I don't know where I saved my previous sample.
I just tried your VBA script and it works almost perfectly. I was not sure if I should put the button on Sheet1 or Sheet2 (maybe it doesn't matter). Tried both and found it works from Sheet2.
I just realized that Sheet2 columnB are all hyperlinks, when my mouse landed on one of the cells. The hyperlinks didn't come over to Sheet1. Is there a way to get that to come over as well? If not, not a big deal. The script works great! Thank you again Peter.
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,511
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

I was not sure if I should put the button on Sheet1 or Sheet2 (maybe it doesn't matter).
It shouldn't matter.

Is there a way to get that to come over as well?
That is not an easy change so I will assume that your comment "not a big deal" can apply. :)
 

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
149
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
It shouldn't matter.


That is not an easy change so I will assume that your comment "not a big deal" can apply. :)
Not a problem. I appreciate all your help. The script is easy enough for me to change if I need to. Thanks again. G'day!
 

Watch MrExcel Video

Forum statistics

Threads
1,129,687
Messages
5,637,832
Members
416,984
Latest member
dee10

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top