Transposing data to a single row

[Mega_man87]

Hello All,

I am struggling to create a Macro that successfully transpose data into a required format. I have attached the initial data and desired format data below. I would like the macro loop through Cell C (Company name) in Sheet "Raw Data" and transpose the information into the required layout shown in Sheet "Results", with each company on a single row.

In Sheet "Results", there is a blank column after each date (and its data) and at the end of the 5th day in that week, a new week is registered and the layout continues.

Please note:
- Weeks will always have 5 days
- If more companies are added to the list, I was like it t follow the same format
- The number of weeks will always be 3 in this report


I would appreciate some help with this so much. Thank you in advance!

Initial Data:

Excel.xlsx
	A	B	C	D	E	F
1	Week Number	Date	Company	Highest Sales	Staff Name	Staff Number
2	1	31/10/2022	Apple	147	Giada Francis	1022
3		01/11/2022	Apple	107	Nathaniel Figueroa	9303
4		02/11/2022	Apple	170	John Doe	1045
5		03/11/2022	Apple	141	Giada Francis	1022
6		04/11/2022	Apple	113	Nathaniel Figueroa	9303
7	2	07/11/2022	Apple	121	John Doe	1045
8		08/11/2022	Apple	192	Nathaniel Figueroa	9303
9		09/11/2022	Apple	62	John Doe	1045
10		10/11/2022	Apple	61	Nathaniel Figueroa	9303
11		11/11/2022	Apple	146	Giada Francis	1022
12	3	14/11/2022	Apple	162	John Doe	1045
13		15/11/2022	Apple	85	Giada Francis	1022
14		16/11/2022	Apple	95	John Doe	1045
15		17/11/2022	Apple	168	Giada Francis	1022
16		18/11/2022	Apple	187	Nathaniel Figueroa	9303
17	1	31/10/2022	Microsoft	127	Lilian Carpenter	22332
18		01/11/2022	Microsoft	126	Ryan Kaur	31828
19		02/11/2022	Microsoft	111	Lilian Carpenter	22332
20		03/11/2022	Microsoft	94	Annette Williams	21939
21		04/11/2022	Microsoft	136	Lilian Carpenter	22332
22	2	07/11/2022	Microsoft	114	Annette Williams	21939
23		08/11/2022	Microsoft	198	Ryan Kaur	31828
24		09/11/2022	Microsoft	59	Annette Williams	21939
25		10/11/2022	Microsoft	181	Lilian Carpenter	22332
26		11/11/2022	Microsoft	70	Ryan Kaur	31828
27	3	14/11/2022	Microsoft	73	Annette Williams	21939
28		15/11/2022	Microsoft	90	Lilian Carpenter	22332
29		16/11/2022	Microsoft	137	Annette Williams	21939
30		17/11/2022	Microsoft	64	Ryan Kaur	31828
31		18/11/2022	Microsoft	179	Lilian Carpenter	22332
32	1	31/10/2022	Samsung	130	Troy Davis	123334
33		01/11/2022	Samsung	144	Jean-Luc Chester	32454
34		02/11/2022	Samsung	139	Dione Hobbs	34474
35		03/11/2022	Samsung	152	Jean-Luc Chester	32454
36		04/11/2022	Samsung	86	Dione Hobbs	34474
37	2	07/11/2022	Samsung	170	Troy Davis	123334
38		08/11/2022	Samsung	158	Jean-Luc Chester	32454
39		09/11/2022	Samsung	145	Dione Hobbs	34474
40		10/11/2022	Samsung	119	Troy Davis	123334
41		11/11/2022	Samsung	63	Dione Hobbs	34474
42	3	14/11/2022	Samsung	100	Jean-Luc Chester	32454
43		15/11/2022	Samsung	119	Troy Davis	123334
44		16/11/2022	Samsung	107	Jean-Luc Chester	32454
45		17/11/2022	Samsung	172	Dione Hobbs	34474
46		18/11/2022	Samsung	121	Troy Davis	123334
Raw Data

Desired Format of Data:

Excel.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK	AL	AM	AN	AO	AP	AQ	AR	AS	AT	AU	AV	AW	AX	AY	AZ	BA	BB	BC	BD	BE	BF	BG	BH	BI	BJ	BK	BL	BM	BN	BO	BP	BQ	BR	BS	BT	BU	BV	BW	BX	BY	BZ
1	Company	Week Number	Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Week Number	Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Week Number	Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales
2	Apple	1	31/10/2022	Giada Francis	1022	147		01/11/2022	Nathaniel Figueroa	9303	107		02/11/2022	John Doe	1045	170		03/11/2022	Giada Francis	1022	141		04/11/2022	Nathaniel Figueroa	9303	113		2	07/11/2022	John Doe	1045	121		08/11/2022	Nathaniel Figueroa	9303	192		09/11/2022	John Doe	1045	62		10/11/2022	Nathaniel Figueroa	9303	61		11/11/2022	Giada Francis	1022	146		3	14/11/2022	John Doe	1045	162		15/11/2022	Giada Francis	1022	85		16/11/2022	John Doe	1045	95		17/11/2022	Giada Francis	1022	168		18/11/2022	Nathaniel Figueroa	9303	187
3	Microsoft	1	31/10/2022	Lilian Carpenter	22332	127		01/11/2022	Ryan Kaur	31828	126		02/11/2022	Lilian Carpenter	22332	111		03/11/2022	Annette Williams	21939	94		04/11/2022	Lilian Carpenter	22332	136		2	07/11/2022	Annette Williams	21939	114		08/11/2022	Ryan Kaur	31828	198		09/11/2022	Annette Williams	21939	59		10/11/2022	Lilian Carpenter	22332	181		11/11/2022	Ryan Kaur	31828	70		3	14/11/2022	Annette Williams	21939	73		15/11/2022	Lilian Carpenter	22332	90		16/11/2022	Annette Williams	21939	137		17/11/2022	Ryan Kaur	31828	64		18/11/2022	Lilian Carpenter	22332	179
4	Samsung	1	31/10/2022	Troy Davis	123334	130		01/11/2022	Jean-Luc Chester	32454	144		02/11/2022	Dione Hobbs	34474	139		03/11/2022	Jean-Luc Chester	32454	152		04/11/2022	Dione Hobbs	34474	86		2	07/11/2022	Troy Davis	123334	170		08/11/2022	Jean-Luc Chester	32454	158		09/11/2022	Dione Hobbs	34474	145		10/11/2022	Troy Davis	123334	119		11/11/2022	Dione Hobbs	34474	63		3	14/11/2022	Jean-Luc Chester	32454	100		15/11/2022	Troy Davis	123334	119		16/11/2022	Jean-Luc Chester	32454	107		17/11/2022	Dione Hobbs	34474	172		18/11/2022	Troy Davis	123334	121
Results

 

[rlv01]

Results:

tmpB.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z
1	Company	Week Number	Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales
2	Apple	1	10/31/2022	Giada Francis	1022	147		11/1/2022	Nathaniel Figueroa	9303	107		11/2/2022	John Doe	1045	170		11/3/2022	Giada Francis	1022	141		11/4/2022	Nathaniel Figueroa	9303	113
3	Microsoft	1	10/31/2022	Lilian Carpenter	22332	127		11/1/2022	Ryan Kaur	31828	126		11/2/2022	Lilian Carpenter	22332	111		11/3/2022	Annette Williams	21939	94		11/4/2022	Lilian Carpenter	22332	136
4	Samsung	1	10/31/2022	Troy Davis	123334	130		11/1/2022	Jean-Luc Chester	32454	144		11/2/2022	Dione Hobbs	34474	139		11/3/2022	Jean-Luc Chester	32454	152		11/4/2022	Dione Hobbs	34474	86
5	Apple	2	11/7/2022	John Doe	1045	121		11/8/2022	Nathaniel Figueroa	9303	192		11/9/2022	John Doe	1045	62		11/10/2022	Nathaniel Figueroa	9303	61		11/11/2022	Giada Francis	1022	146
6	Microsoft	2	11/7/2022	Annette Williams	21939	114		11/8/2022	Ryan Kaur	31828	198		11/9/2022	Annette Williams	21939	59		11/10/2022	Lilian Carpenter	22332	181		11/11/2022	Ryan Kaur	31828	70
7	Samsung	2	11/7/2022	Troy Davis	123334	170		11/8/2022	Jean-Luc Chester	32454	158		11/9/2022	Dione Hobbs	34474	145		11/10/2022	Troy Davis	123334	119		11/11/2022	Dione Hobbs	34474	63
8	Apple	3	11/14/2022	John Doe	1045	162		11/15/2022	Giada Francis	1022	85		11/16/2022	John Doe	1045	95		11/17/2022	Giada Francis	1022	168		11/18/2022	Nathaniel Figueroa	9303	187
9	Microsoft	3	11/14/2022	Annette Williams	21939	73		11/15/2022	Lilian Carpenter	22332	90		11/16/2022	Annette Williams	21939	137		11/17/2022	Ryan Kaur	31828	64		11/18/2022	Lilian Carpenter	22332	179
10	Samsung	3	11/14/2022	Jean-Luc Chester	32454	100		11/15/2022	Troy Davis	123334	119		11/16/2022	Jean-Luc Chester	32454	107		11/17/2022	Dione Hobbs	34474	172		11/18/2022	Troy Davis	123334	121
Results

Code:

Sub DoSomething()
    Dim WDate As Date
    Dim I As Long, J As Long, Ofs As Long, StaffNumber As Long
    Dim CellRange As Range, Dest As Range, R As Range
    Dim Key As String, LastKey As String, StaffName As String
    Dim Sales As Variant
    Dim WB As Workbook
    Dim WS As Worksheet, WSR As Worksheet

    Set WB = ActiveWorkbook
    Set WSR = WB.Worksheets("Raw Data")
    Set WS = WB.Worksheets("Results")
    WS.UsedRange.Clear
    WS.Activate
    Application.ScreenUpdating = False

    With WSR
        Set CellRange = .Range("A1:F" & .Range("B" & .Rows.Count).End(xlUp).Row)
        CellRange.Copy WS.Range("A1")
    End With

    With WS
        Set CellRange = .Range("A2:A" & .Range("B" & .Rows.Count).End(xlUp).Row)    'range to last cell in column w/data
    End With

    For Each R In CellRange
        If IsNumeric(R.Value) And Not Trim(R.Value) = "" Then
            J = R.Value
        End If

        If Trim(R.Value) = "" Then
            R.Value = J
        End If
    Next R

    With WS
        Set CellRange = .Range("C2:C" & .Range("C" & .Rows.Count).End(xlUp).Row)    'range to last cell in column w/data
        LastKey = .Range("C2").Value & "$" & .Range("A2").Value
        Set Dest = .Range("H1")
        Ofs = 1
        I = 1
    End With

    With Dest
        .Value = "Company"
        .Offset(0, 1).Value = "Week Number"
        .Offset(Ofs, 0).Value = Split(LastKey, "$")(0)
        .Offset(Ofs, 1).Value = Split(LastKey, "$")(1)
    End With

    For Each R In CellRange
        Key = R.Offset(0, 0).Value & "$" & R.Offset(0, -2).Value
        WDate = R.Offset(0, -1).Value
        StaffName = R.Offset(0, 2).Value
        StaffNumber = R.Offset(0, 3).Value
        Sales = R.Offset(0, 1).Value

        If Key <> LastKey Then
            LastKey = Key
            Ofs = Ofs + 1
            I = 1
            With Dest
                .Offset(Ofs, 0).Value = Split(LastKey, "$")(0)
                .Offset(Ofs, 1).Value = Split(LastKey, "$")(1)
            End With
        End If

        J = WS.Cells(Ofs + 1, WS.Columns.Count).End(xlToLeft).Column
        If I > 1 Then
            J = J + 1
        Else
            I = I + 1
        End If

        WS.Cells(1, J + 1).Value = "Date"
        WS.Cells(Ofs + 1, J + 1).Value = WDate

        WS.Cells(1, J + 2).Value = "Staff Name"
        WS.Cells(Ofs + 1, J + 2).Value = StaffName

        WS.Cells(1, J + 3).Value = "Staff Number"
        WS.Cells(Ofs + 1, J + 3).Value = StaffNumber

        WS.Cells(1, J + 4).Value = "Sales"
        WS.Cells(Ofs + 1, J + 4).Value = Sales
    Next R
    With WS
        .Range("A1:G1").EntireColumn.Delete
        .UsedRange.Columns.ColumnWidth = 5
        .UsedRange.Columns.AutoFit
        .UsedRange.Sort Key1:=.Range("B1"), Order1:=xlAscending, Key2:=.Range("A1"), Order2:=xlAscending, Header:=xlYes
    End With
    Application.ScreenUpdating = True
End Sub

 

[Mega_man87]

Results:

tmpB.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z
1	Company	Week Number	Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales
2	Apple	1	10/31/2022	Giada Francis	1022	147		11/1/2022	Nathaniel Figueroa	9303	107		11/2/2022	John Doe	1045	170		11/3/2022	Giada Francis	1022	141		11/4/2022	Nathaniel Figueroa	9303	113
3	Microsoft	1	10/31/2022	Lilian Carpenter	22332	127		11/1/2022	Ryan Kaur	31828	126		11/2/2022	Lilian Carpenter	22332	111		11/3/2022	Annette Williams	21939	94		11/4/2022	Lilian Carpenter	22332	136
4	Samsung	1	10/31/2022	Troy Davis	123334	130		11/1/2022	Jean-Luc Chester	32454	144		11/2/2022	Dione Hobbs	34474	139		11/3/2022	Jean-Luc Chester	32454	152		11/4/2022	Dione Hobbs	34474	86
5	Apple	2	11/7/2022	John Doe	1045	121		11/8/2022	Nathaniel Figueroa	9303	192		11/9/2022	John Doe	1045	62		11/10/2022	Nathaniel Figueroa	9303	61		11/11/2022	Giada Francis	1022	146
6	Microsoft	2	11/7/2022	Annette Williams	21939	114		11/8/2022	Ryan Kaur	31828	198		11/9/2022	Annette Williams	21939	59		11/10/2022	Lilian Carpenter	22332	181		11/11/2022	Ryan Kaur	31828	70
7	Samsung	2	11/7/2022	Troy Davis	123334	170		11/8/2022	Jean-Luc Chester	32454	158		11/9/2022	Dione Hobbs	34474	145		11/10/2022	Troy Davis	123334	119		11/11/2022	Dione Hobbs	34474	63
8	Apple	3	11/14/2022	John Doe	1045	162		11/15/2022	Giada Francis	1022	85		11/16/2022	John Doe	1045	95		11/17/2022	Giada Francis	1022	168		11/18/2022	Nathaniel Figueroa	9303	187
9	Microsoft	3	11/14/2022	Annette Williams	21939	73		11/15/2022	Lilian Carpenter	22332	90		11/16/2022	Annette Williams	21939	137		11/17/2022	Ryan Kaur	31828	64		11/18/2022	Lilian Carpenter	22332	179
10	Samsung	3	11/14/2022	Jean-Luc Chester	32454	100		11/15/2022	Troy Davis	123334	119		11/16/2022	Jean-Luc Chester	32454	107		11/17/2022	Dione Hobbs	34474	172		11/18/2022	Troy Davis	123334	121
Results

Code:

Sub DoSomething()
    Dim WDate As Date
    Dim I As Long, J As Long, Ofs As Long, StaffNumber As Long
    Dim CellRange As Range, Dest As Range, R As Range
    Dim Key As String, LastKey As String, StaffName As String
    Dim Sales As Variant
    Dim WB As Workbook
    Dim WS As Worksheet, WSR As Worksheet

    Set WB = ActiveWorkbook
    Set WSR = WB.Worksheets("Raw Data")
    Set WS = WB.Worksheets("Results")
    WS.UsedRange.Clear
    WS.Activate
    Application.ScreenUpdating = False

    With WSR
        Set CellRange = .Range("A1:F" & .Range("B" & .Rows.Count).End(xlUp).Row)
        CellRange.Copy WS.Range("A1")
    End With

    With WS
        Set CellRange = .Range("A2:A" & .Range("B" & .Rows.Count).End(xlUp).Row)    'range to last cell in column w/data
    End With

    For Each R In CellRange
        If IsNumeric(R.Value) And Not Trim(R.Value) = "" Then
            J = R.Value
        End If

        If Trim(R.Value) = "" Then
            R.Value = J
        End If
    Next R

    With WS
        Set CellRange = .Range("C2:C" & .Range("C" & .Rows.Count).End(xlUp).Row)    'range to last cell in column w/data
        LastKey = .Range("C2").Value & "$" & .Range("A2").Value
        Set Dest = .Range("H1")
        Ofs = 1
        I = 1
    End With

    With Dest
        .Value = "Company"
        .Offset(0, 1).Value = "Week Number"
        .Offset(Ofs, 0).Value = Split(LastKey, "$")(0)
        .Offset(Ofs, 1).Value = Split(LastKey, "$")(1)
    End With

    For Each R In CellRange
        Key = R.Offset(0, 0).Value & "$" & R.Offset(0, -2).Value
        WDate = R.Offset(0, -1).Value
        StaffName = R.Offset(0, 2).Value
        StaffNumber = R.Offset(0, 3).Value
        Sales = R.Offset(0, 1).Value

        If Key <> LastKey Then
            LastKey = Key
            Ofs = Ofs + 1
            I = 1
            With Dest
                .Offset(Ofs, 0).Value = Split(LastKey, "$")(0)
                .Offset(Ofs, 1).Value = Split(LastKey, "$")(1)
            End With
        End If

        J = WS.Cells(Ofs + 1, WS.Columns.Count).End(xlToLeft).Column
        If I > 1 Then
            J = J + 1
        Else
            I = I + 1
        End If

        WS.Cells(1, J + 1).Value = "Date"
        WS.Cells(Ofs + 1, J + 1).Value = WDate

        WS.Cells(1, J + 2).Value = "Staff Name"
        WS.Cells(Ofs + 1, J + 2).Value = StaffName

        WS.Cells(1, J + 3).Value = "Staff Number"
        WS.Cells(Ofs + 1, J + 3).Value = StaffNumber

        WS.Cells(1, J + 4).Value = "Sales"
        WS.Cells(Ofs + 1, J + 4).Value = Sales
    Next R
    With WS
        .Range("A1:G1").EntireColumn.Delete
        .UsedRange.Columns.ColumnWidth = 5
        .UsedRange.Columns.AutoFit
        .UsedRange.Sort Key1:=.Range("B1"), Order1:=xlAscending, Key2:=.Range("A1"), Order2:=xlAscending, Header:=xlYes
    End With
    Application.ScreenUpdating = True
End Sub

Hello rlv01,

Thank you for the response. I've tried the code you sent which works perfectly, however it doesn't quite give the desired format. Each company needs to be on a single row i.e no duplicates within the company column in sheet "Results"

Here's the desired format for the results:

Excel.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK	AL	AM	AN	AO	AP	AQ	AR	AS	AT	AU	AV	AW	AX	AY	AZ	BA	BB	BC	BD	BE	BF	BG	BH	BI	BJ	BK	BL	BM	BN	BO	BP	BQ	BR	BS	BT	BU	BV	BW	BX	BY	BZ
1	Company	Week Number	Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Week Number	Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Week Number	Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales		Date	Staff Name	Staff Number	Sales
2	Apple	1	31/10/2022	Giada Francis	1022	147		01/11/2022	Nathaniel Figueroa	9303	107		02/11/2022	John Doe	1045	170		03/11/2022	Giada Francis	1022	141		04/11/2022	Nathaniel Figueroa	9303	113		2	07/11/2022	John Doe	1045	121		08/11/2022	Nathaniel Figueroa	9303	192		09/11/2022	John Doe	1045	62		10/11/2022	Nathaniel Figueroa	9303	61		11/11/2022	Giada Francis	1022	146		3	14/11/2022	John Doe	1045	162		15/11/2022	Giada Francis	1022	85		16/11/2022	John Doe	1045	95		17/11/2022	Giada Francis	1022	168		18/11/2022	Nathaniel Figueroa	9303	187
3	Microsoft	1	31/10/2022	Lilian Carpenter	22332	127		01/11/2022	Ryan Kaur	31828	126		02/11/2022	Lilian Carpenter	22332	111		03/11/2022	Annette Williams	21939	94		04/11/2022	Lilian Carpenter	22332	136		2	07/11/2022	Annette Williams	21939	114		08/11/2022	Ryan Kaur	31828	198		09/11/2022	Annette Williams	21939	59		10/11/2022	Lilian Carpenter	22332	181		11/11/2022	Ryan Kaur	31828	70		3	14/11/2022	Annette Williams	21939	73		15/11/2022	Lilian Carpenter	22332	90		16/11/2022	Annette Williams	21939	137		17/11/2022	Ryan Kaur	31828	64		18/11/2022	Lilian Carpenter	22332	179
4	Samsung	1	31/10/2022	Troy Davis	123334	130		01/11/2022	Jean-Luc Chester	32454	144		02/11/2022	Dione Hobbs	34474	139		03/11/2022	Jean-Luc Chester	32454	152		04/11/2022	Dione Hobbs	34474	86		2	07/11/2022	Troy Davis	123334	170		08/11/2022	Jean-Luc Chester	32454	158		09/11/2022	Dione Hobbs	34474	145		10/11/2022	Troy Davis	123334	119		11/11/2022	Dione Hobbs	34474	63		3	14/11/2022	Jean-Luc Chester	32454	100		15/11/2022	Troy Davis	123334	119		16/11/2022	Jean-Luc Chester	32454	107		17/11/2022	Dione Hobbs	34474	172		18/11/2022	Troy Davis	123334	121
Results

Thank you!

 

[rlv01]

Sub Reformat()
    Dim WDate As Date
    Dim I As Long, J As Long, Ofs As Long, StaffNumber As Long
    Dim CellRange As Range, Dest As Range, R As Range
    Dim Key As String, LastKey As String, StaffName As String
    Dim Sales As Variant
    Dim WB As Workbook
    Dim WS As Worksheet, WSR As Worksheet
    Dim LastRow As Long
    Dim Company As String, NextCompany As String
    Dim HeaderCol As Long, DataCol As Long
    Dim HeaderColRange As Range, DataColRange As Range

    Set WB = ActiveWorkbook
    Set WSR = WB.Worksheets("Raw Data")
    Set WS = WB.Worksheets("Results")
    WS.UsedRange.Clear
    WS.Activate
    Application.ScreenUpdating = False

    With WSR
        Set CellRange = .Range("A1:F" & .Range("B" & .Rows.Count).End(xlUp).Row)
        CellRange.Copy WS.Range("A1")
    End With

    With WS
        Set CellRange = .Range("A2:A" & .Range("B" & .Rows.Count).End(xlUp).Row)    'range to last cell in column w/data
    End With

    For Each R In CellRange
        If IsNumeric(R.Value) And Not Trim(R.Value) = "" Then
            J = R.Value
        End If

        If Trim(R.Value) = "" Then
            R.Value = J
        End If
    Next R

    With WS
        Set CellRange = .Range("C2:C" & .Range("C" & .Rows.Count).End(xlUp).Row)    'range to last cell in column w/data
        LastKey = .Range("C2").Value & "$" & .Range("A2").Value
        Set Dest = .Range("H1")
        Ofs = 1
        I = 1
    End With

    With Dest
        .Value = "Company"
        .Offset(0, 1).Value = "Week Number"
        .Offset(Ofs, 0).Value = Split(LastKey, "$")(0)
        .Offset(Ofs, 1).Value = Split(LastKey, "$")(1)
    End With

    For Each R In CellRange
        Key = R.Offset(0, 0).Value & "$" & R.Offset(0, -2).Value
        WDate = R.Offset(0, -1).Value
        StaffName = R.Offset(0, 2).Value
        StaffNumber = R.Offset(0, 3).Value
        Sales = R.Offset(0, 1).Value

        If Key <> LastKey Then
            LastKey = Key
            Ofs = Ofs + 1
            I = 1
            With Dest
                .Offset(Ofs, 0).Value = Split(LastKey, "$")(0)
                .Offset(Ofs, 1).Value = Split(LastKey, "$")(1)
            End With
        End If

        J = WS.Cells(Ofs + 1, WS.Columns.Count).End(xlToLeft).Column
        If I > 1 Then
            J = J + 1
        Else
            I = I + 1
        End If

        WS.Cells(1, J + 1).Value = "Date"
        WS.Cells(Ofs + 1, J + 1).Value = WDate

        WS.Cells(1, J + 2).Value = "Staff Name"
        WS.Cells(Ofs + 1, J + 2).Value = StaffName

        WS.Cells(1, J + 3).Value = "Staff Number"
        WS.Cells(Ofs + 1, J + 3).Value = StaffNumber

        WS.Cells(1, J + 4).Value = "Sales"
        WS.Cells(Ofs + 1, J + 4).Value = Sales
    Next R
    With WS
        .Range("A1:G1").EntireColumn.Delete
    End With

    '2nd part
    With WS
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row    'last row w/data
        Set CellRange = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
    End With

    With WS.Range("B1")
        Set HeaderColRange = WS.Range(.Offset(0, 0), WS.Cells(.Row, WS.Columns.Count).End(xlToLeft))
    End With
    HeaderCol = WS.Cells(1, WS.Columns.Count).End(xlToLeft).Column

    For I = LastRow To 2 Step -1
        DataCol = WS.Cells(I - 1, WS.Columns.Count).End(xlToLeft).Column

        With WS.Range("B1")
            Set DataColRange = WS.Range(.Offset(I - 1, 0), WS.Cells(.Offset(I - 1, 0).Row, WS.Columns.Count).End(xlToLeft))
        End With

        Company = DataColRange.Range("A1").Offset(0, -1).Value
        NextCompany = DataColRange.Range("A1").Offset(-1, -1).Value

        If Company = NextCompany Then
            DataColRange.Cut DataColRange.Offset(-1, DataCol)
            DataCol = WS.Cells(I - 2, WS.Columns.Count).End(xlToLeft).Column
            HeaderColRange.Copy HeaderColRange.Offset(0, DataCol)
            DataColRange.Offset(1).EntireRow.Delete
        End If
    Next I

    WS.UsedRange.Columns.ColumnWidth = 5
    WS.UsedRange.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

 

[Mega_man87]

Sub Reformat()
    Dim WDate As Date
    Dim I As Long, J As Long, Ofs As Long, StaffNumber As Long
    Dim CellRange As Range, Dest As Range, R As Range
    Dim Key As String, LastKey As String, StaffName As String
    Dim Sales As Variant
    Dim WB As Workbook
    Dim WS As Worksheet, WSR As Worksheet
    Dim LastRow As Long
    Dim Company As String, NextCompany As String
    Dim HeaderCol As Long, DataCol As Long
    Dim HeaderColRange As Range, DataColRange As Range

    Set WB = ActiveWorkbook
    Set WSR = WB.Worksheets("Raw Data")
    Set WS = WB.Worksheets("Results")
    WS.UsedRange.Clear
    WS.Activate
    Application.ScreenUpdating = False

    With WSR
        Set CellRange = .Range("A1:F" & .Range("B" & .Rows.Count).End(xlUp).Row)
        CellRange.Copy WS.Range("A1")
    End With

    With WS
        Set CellRange = .Range("A2:A" & .Range("B" & .Rows.Count).End(xlUp).Row)    'range to last cell in column w/data
    End With

    For Each R In CellRange
        If IsNumeric(R.Value) And Not Trim(R.Value) = "" Then
            J = R.Value
        End If

        If Trim(R.Value) = "" Then
            R.Value = J
        End If
    Next R

    With WS
        Set CellRange = .Range("C2:C" & .Range("C" & .Rows.Count).End(xlUp).Row)    'range to last cell in column w/data
        LastKey = .Range("C2").Value & "$" & .Range("A2").Value
        Set Dest = .Range("H1")
        Ofs = 1
        I = 1
    End With

    With Dest
        .Value = "Company"
        .Offset(0, 1).Value = "Week Number"
        .Offset(Ofs, 0).Value = Split(LastKey, "$")(0)
        .Offset(Ofs, 1).Value = Split(LastKey, "$")(1)
    End With

    For Each R In CellRange
        Key = R.Offset(0, 0).Value & "$" & R.Offset(0, -2).Value
        WDate = R.Offset(0, -1).Value
        StaffName = R.Offset(0, 2).Value
        StaffNumber = R.Offset(0, 3).Value
        Sales = R.Offset(0, 1).Value

        If Key <> LastKey Then
            LastKey = Key
            Ofs = Ofs + 1
            I = 1
            With Dest
                .Offset(Ofs, 0).Value = Split(LastKey, "$")(0)
                .Offset(Ofs, 1).Value = Split(LastKey, "$")(1)
            End With
        End If

        J = WS.Cells(Ofs + 1, WS.Columns.Count).End(xlToLeft).Column
        If I > 1 Then
            J = J + 1
        Else
            I = I + 1
        End If

        WS.Cells(1, J + 1).Value = "Date"
        WS.Cells(Ofs + 1, J + 1).Value = WDate

        WS.Cells(1, J + 2).Value = "Staff Name"
        WS.Cells(Ofs + 1, J + 2).Value = StaffName

        WS.Cells(1, J + 3).Value = "Staff Number"
        WS.Cells(Ofs + 1, J + 3).Value = StaffNumber

        WS.Cells(1, J + 4).Value = "Sales"
        WS.Cells(Ofs + 1, J + 4).Value = Sales
    Next R
    With WS
        .Range("A1:G1").EntireColumn.Delete
    End With

    '2nd part
    With WS
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row    'last row w/data
        Set CellRange = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
    End With

    With WS.Range("B1")
        Set HeaderColRange = WS.Range(.Offset(0, 0), WS.Cells(.Row, WS.Columns.Count).End(xlToLeft))
    End With
    HeaderCol = WS.Cells(1, WS.Columns.Count).End(xlToLeft).Column

    For I = LastRow To 2 Step -1
        DataCol = WS.Cells(I - 1, WS.Columns.Count).End(xlToLeft).Column

        With WS.Range("B1")
            Set DataColRange = WS.Range(.Offset(I - 1, 0), WS.Cells(.Offset(I - 1, 0).Row, WS.Columns.Count).End(xlToLeft))
        End With

        Company = DataColRange.Range("A1").Offset(0, -1).Value
        NextCompany = DataColRange.Range("A1").Offset(-1, -1).Value

        If Company = NextCompany Then
            DataColRange.Cut DataColRange.Offset(-1, DataCol)
            DataCol = WS.Cells(I - 2, WS.Columns.Count).End(xlToLeft).Column
            HeaderColRange.Copy HeaderColRange.Offset(0, DataCol)
            DataColRange.Offset(1).EntireRow.Delete
        End If
    Next I

    WS.UsedRange.Columns.ColumnWidth = 5
    WS.UsedRange.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

Hello rlvo1,

Thank you for the response. The updated code works prefectly and provides the desired format - I appreciate your help.

If you could, could you please some more comments on the code for my understanding for next time as I am relatively new to VBA?

Thank you.