VBA: Transpose & CONCATENATE

[NeoSez]

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.

A	B	C	D	E	F	G	H	I
HEADER1	pr#	PR NAME	PM	DEADLINE	HEADER6	HEADER7	HEADER8	HEADER9
	123	Sample1	NAME1	25-Dec-20
	234	Sample2	NAME1	26-Dec-20
	345	Sample3	NAME1	27-Dec-20
	456	Sample4	NAME2	28-Dec-20
	457	Sample5	NAME3	29-Dec-20
	458	Sample6	NAME4	30-Dec-20
	459	Sample7	NAME5	31-Dec-20
	460	Sample8	NAME3	1-Jan-21
	461	Sample9	NAME4	2-Jan-21
	462	Sample10	NAME5	3-Jan-21
SHEET 2

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

A	B	C	D	E	F	G	H
NAME1	NAME2	NAME3	NAME4	NAME5	NAME6	NAME7	NAME8
CONCATENATE
12/25/2020 PR#123 PR NAME	12/28/2020 PR#456 PR NAME
SHEET1

 

[NeoSez]

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.

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

 

[Peter_SSs]

Could you show the full expected results for NAME1, NAME2 and NAME3?

 

[NeoSez]

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.

=CONCATENATE(TEXT(E23, "mm/dd/yyyy"),CHAR(10),B23,CHAR(10),D23,CHAR(10),C23,CHAR(10))

Expected Results

A	B	C	D	E	F	G	H
NAME1	NAME2	NAME3	NAME4	NAME5	NAME6	NAME7	NAME8
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:

A	B	C	D	E	F	G	H	I
HEADER1	pr#	PR NAME	PM	DEADLINE	HEADER6	HEADER7	HEADER8	HEADER9
	123	Sample1	NAME1	12/23/2020
	234	Sample2	NAME1	12/24/2020
	345	Sample3	NAME1	12/25/2020
	456	Sample4	NAME2	12/26/2020
	457	Sample5	NAME3	12/27/2020
	458	Sample6	NAME4	12/28/2020
	459	Sample7	NAME5	12/29/2020
	460	Sample8	NAME3	12/30/2020
	461	Sample9	NAME4	12/31/2020
	462	Sample10	NAME5	1/1/2021
SHEET 2

 

[Peter_SSs]

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.

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

 

[NeoSez]

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]

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]

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!

 

[Peter_SSs]