Transpose Values VBA for week

[mahmed1]

Hi All,

I have a data set that is stored like this (I dont need total in output)

Area	Date	Mon	Tue	Wed	Thu	Fri	Sat	Sun	Total
Team 1	20-07-20	14	37	20	32	34	35	24	196
Team 1	27-07-20	48	46	36	48	10	2	16	206
Team 2	20-07-20	38	31	42	16	10	10	3	150
Team 2	27-07-20	33	15	15	19	31	47	27	187

How can i use VBA to transpose the information in a tabular format like below

Area	Date	Incoming
Team 1	20/07/2020	14
Team 1	21/07/2020	37
Team 1	22/07/2020	20
Team 1	23/07/2020	32
Team 1	24/07/2020	34
Team 1	25/07/2020	35
Team 1	26/07/2020	24
Team 1	27/07/2020	48
Team 1	28/07/2020	46
Team 1	29/07/2020	36
Team 1	30/07/2020	48
Team 1	31/07/2020	10
Team 1	01/08/2020	2
Team 1	02/08/2020	16
Team2	20/07/2020	38
Team2	21/07/2020	31
Team2	22/07/2020	42
Team2	23/07/2020	16
Team2	24/07/2020	10
Team2	25/07/2020	10
Team2	26/07/2020	3
Team2	27/07/2020	33
Team2	28/07/2020	15
Team2	29/07/2020	15
Team2	30/07/2020	19
Team2	31/07/2020	31
Team2	01/08/2020	47
Team2	02/08/2020	27

My Sheet is called Data and the headings start from A1

Many Thanks

 

[mahmed1]

Source Data

Area	Date	Mon	Tue	Wed	Thu	Fri	Sat	Sun	Total	ID	Type
Team 1	20-07-20	43	42	48	93	55	19	19	318	2005	Mailing

Output format

Date	Area	Incoming Volume	ID	Type
20-07-20	Team 1	43	2005	Mailing
21-07-20	Team 1	42	2005	Mailing
22-07-20	Team 1	48	2005	Mailing
23-07-20	Team 1	93	2005	Mailing
24-07-20	Team 1	55	2005	Mailing
25-07-20	Team 1	19	2005	Mailing
26-07-20	Team 1	19	2005	Mailing

 

[mahmed1]

Hi Again - Date formatted as date and numbers with no decimals - Thank You

 

[Fluff]

How about

Sub mahmed()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, nr As Long, c As Long
   
   Ary = Sheets("Data").Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary) * UBound(Ary, 2), 1 To 5)
   
   For r = 2 To UBound(Ary)
      For c = 3 To 9
         nr = nr + 1
         Nary(nr, 2) = Ary(r, 1)
         Nary(nr, 1) = Ary(r, 2) + c - 3
         Nary(nr, 3) = Ary(r, c)
         Nary(nr, 4) = Ary(r, 11)
         Nary(nr, 5) = Ary(r, 12)
      Next c
   Next r
   With Sheets("Pastesheet").ListObjects("tblIncoming")
      .DataBodyRange.Delete
      .Parent.Range("A2").Resize(nr, 5).Value = Nary
   End With
End Sub

 

[mahmed1]

Awesome Thank you

 

[Fluff]

Glad to help & thanks for the feedback.