Flipping values in excel to column titles

[Dreamteam]

Hi all,

I try to reserve any questions to this forum that are a little challenging - so apologies for the following as I really should know how to do this. In short, a taxi company has daily contracts and simply add which taxis took the job - at the end of the month the drivers get paid. The contracts are at the top, the dates on the side and whichever taxi does the job gets entered into the data in the spread sheet (taxis 3,5,6,7,8,14 or 15). All I want to do is flip this information so that the taxi references are at the top and the contracts are in the spread sheet. I have highlighted a possible scenario where one of the drivers complete more that 2 jobs in the day - I thought that this would be the only difficult part but for me I am struggling (looking at this I don't think it has come out highlighted). I have tried using Tables/Pivot Tables but to no avail.

Any help would be much appreciated.

Many thanks

Dt

CURRENT STATE

DATE	DAY	AM/PM	COSAWES	BASS ACC	SWAN MONG	PL PL SAINS	BERKLEY COTT	PL PL DRAC	TREGEW
01/02/2019	FRI	AM	5	14	7
01/02/2019	FRI	PM	5	14	3
02/02/2019	SAT	AM
02/02/2019	SAT	PM
03/02/2019	SUN	AM
03/02/2019	SUN	PM
04/02/2019	MON	AM	7	15	3		5
04/02/2019	MON	PM	7	15	14
05/02/2019	TUE	AM	8	7	5	3
05/02/2019	TUE	PM	8	7	5	3	5

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

WOULD I IMAGINE IT TO LOOK LIKE

DATE	DAY	AM/PM	3	5	6	7	8	14	15
01/02/2019	FRI	AM		COSAWES		SWAN MONGL		BASS ACC
01/02/2019	FRI	PM	SWAN MONGL	COSAWES				BASS ACC
02/02/2019	SAT	AM
02/02/2019	SAT	PM
03/02/2019	SUN	AM
03/02/2019	SUN	PM
04/02/2019	MON	AM	SWAN MONGL	BERK COTT		COSAWES			BASS ACC
04/02/2019	MON	PM				COSAWES		SWAN MONGL	BASS ACC
05/02/2019	TUE	AM	PL PL SAINS	SWAN MONGL		BASS ACC	COSAWES
05/02/2019	TUE	PM	PL PL SAINS	SWAN MONGL		BASS ACC	COSAWES
05/02/2019	TUE	PM		BERK COTT

<colgroup><col><col span="2"><col span="2"><col><col><col><col><col></colgroup><tbody>
</tbody>

 

[MickG]

Try this:-
NB:- The word "DATE" in column "A" data is assumed to start in "A1".
NB:- This code will alter your Data !!

[COLOR="Navy"]Sub[/COLOR] MG26Jan20
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Taxi [COLOR="Navy"]As[/COLOR] Variant, P [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Taxi = Array(3, 5, 6, 7, 8, 14, 15)
Lst = Cells("1", Columns.Count).End(xlToLeft).Column
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("D2"), Range("D" & Rows.Count).End(xlUp)).Resize(, Lst)

[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not IsEmpty(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] Not .exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            .Add Dn.Value, Dn
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
        
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]

[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, nRng [COLOR="Navy"]As[/COLOR] Range, R [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Rng.ClearContents
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Taxi
        c = c + 1
        [COLOR="Navy"]If[/COLOR] .exists(Val(R)) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] P [COLOR="Navy"]In[/COLOR] .Item(Val(R))
                Cells(P.Row, c + 3) = Cells(1, P.Column).Value
            [COLOR="Navy"]Next[/COLOR] P
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] R
      Range("D1").Resize(, UBound(Taxi) + 1) = Taxi
 [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Dreamteam]

Hi Mick

Many many thanks for this

Why can't I write code off the bat like this!

Your code works great - apart from when the taxi completes more than 2 jobs for the day - for example on 05/02/2019 Taxi 5 completes SWAN MONGL on both am and pm and another job in the pm.

Bit tricky I think

Many thanks

Dt

 

[MickG]

Try this enhanced code for duplicates jobs in any line
Run the code from the activesheet (data sheet) for results on sheet2.

[COLOR="Navy"]Sub[/COLOR] MG27Jan07
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] Range, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, P [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] dic [COLOR="Navy"]As[/COLOR] Object, nRng [COLOR="Navy"]As[/COLOR] Range, R [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]With[/COLOR] ActiveSheet
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    Lst = .Cells("1", Columns.Count).End(xlToLeft).Column
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Set[/COLOR] dic = CreateObject("scripting.dictionary")
dic.CompareMode = vbTextCompare
oMax = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    c = c + oMax
  oMax = 0
 [COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
    Dn.Resize(, Lst).Copy .Cells(c, 1)
    [COLOR="Navy"]Set[/COLOR] nRng = .Cells(c, 1).Resize(, Lst)
    dic.RemoveAll
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] nRng
        [COLOR="Navy"]If[/COLOR] R.Column > 3 [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] R.Value <> "" [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]If[/COLOR] Not dic.Exists(R.Value) [COLOR="Navy"]Then[/COLOR]
                    dic.Add R.Value, 0
                [COLOR="Navy"]Else[/COLOR]
                    dic(R.Value) = dic(R.Value) + 1
                    oMax = Application.Max(dic(R.Value), oMax)
                    nRng(1).Resize(, 3).Copy nRng(1).Offset(dic(R.Value))
                    R.Cut R.Offset(dic(R.Value))
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
   [COLOR="Navy"]Next[/COLOR] R
oMax = oMax + 1
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Next[/COLOR] Dn
namchange
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
[COLOR="Navy"]Sub[/COLOR] namchange()
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Taxi [COLOR="Navy"]As[/COLOR] Variant, P [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] dic [COLOR="Navy"]As[/COLOR] Object
Taxi = Array(3, 5, 6, 7, 8, 14, 15)
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
    Lst = .Cells("1", Columns.Count).End(xlToLeft).Column
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("C2", .Range("C" & Rows.Count).End(xlUp))
    [COLOR="Navy"]Set[/COLOR] Rng = Rng.Offset(, 1).Resize(, Lst)


[COLOR="Navy"]Set[/COLOR] dic = CreateObject("scripting.dictionary")
dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not IsEmpty(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] Not dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            dic.Add Dn.Value, Dn
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]Set[/COLOR] dic(Dn.Value) = Union(dic(Dn.Value), Dn)
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]

[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, nRng [COLOR="Navy"]As[/COLOR] Range, R [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Rng.ClearContents
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Taxi
        c = c + 1
        [COLOR="Navy"]If[/COLOR] dic.Exists(Val(R)) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] P [COLOR="Navy"]In[/COLOR] dic(Val(R))
                .Cells(P.Row, c + 3) = .Cells(1, P.Column).Value
            [COLOR="Navy"]Next[/COLOR] P
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] R
.Range("D1").Resize(, UBound(Taxi) + 1) = Taxi
.UsedRange.Columns.AutoFit
.UsedRange.Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Dreamteam]

Mick - I don't know what to say. Well I do - 1) Thank you so much for this. I got a bit obsessed with it and I have been considering it for all of yesterday and yesterday evening. 2) How can I learn to this level of coding? I seem to spend forever on even the most basic problems.

Anyway - thank you once again :~)

Dt

 

[MickG]

You're very welcome
Glad it appears to be working for you !!!