Check for a cell value change

[Wills1971]

Hi All,

I have a spreadsheet that contains peoples names in a column and different values associated to the person in another column e.g.
Wright 1.5
Wright 3
Wright 4.2
Wright 7
Jones 4.6
Jones 2.1
Wilson 9
Wilson 6.7
Wilson 1
Wilson 3.2
Wilson 5

I want to be able to read the name in the column copy it and also copy the associated values for the name and paste them in to a row on another worksheet. Then repeat the process for each name in the column. So I end up with e.g.

Wright 1.5 3 4.2 7
Jones 4.6 2.1
Wilson 9 6.7 1 3.2 5

Many thanks in advance
Will

 

[MickG]

Try this for results on sheet2, starting "A1".

[COLOR="Navy"]Sub[/COLOR] MG24Jan59
[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] dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[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 dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        dic.Add Dn.Value, Dn.Offset(, 1).Value
    [COLOR="Navy"]Else[/COLOR]
        dic(Dn.Value) = dic(Dn.Value) & ", " & Dn.Offset(, 1).Value
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(dic.Count, 2)
    .Value = Application.Transpose(Array(dic.Keys, dic.items))
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Wills1971]

Hi Mick,
I tried running your code, it is copying the contents of column A & B then pasting them in to Columns A & B on sheet2 and putting a border around each cell.

I have a spreadsheet with 9 headings (on columns A to I). Column B is the persons name, this person will be entered in column B down X amount of rows, then the next persons will name will be entered also down X amount of rows. A value for the person is entered in column H.
For example if the name Wright is entered in column B from B2 to B6 a value will be entered in H2 to H6 for them, then the next persons name will be entered in to column B and may have entries from B7 to B10 with a corresponding value in column H from H7 to H10. Then another name will be in B11 to B26 for example with values in column H H11 to H26 for them. Then another name is added in column B etc.

I would like to put the values on one row for each person on sheet2. For example the persons name in cell A2 and then the values in each cell in row 2. Then the next name in A3 and their values along row 3 etc.

Hope this explanation helps a bit more

many thanks,
Will

 

[MickG]

Try this, for data starting Row2, and Results on sheet2 starting row 2.

[COLOR=navy]Sub[/COLOR] MG25Jan29
[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] Dic [COLOR=navy]As[/COLOR] Object, Sp [COLOR=navy]As[/COLOR] Variant, K [COLOR=navy]As[/COLOR] Variant, c [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
[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 Dic.exists(Dn.Value) [COLOR=navy]Then[/COLOR]
        Dic.Add Dn.Value, Dn.Offset(, 6).Value
    [COLOR=navy]Else[/COLOR]
        Dic(Dn.Value) = Dic(Dn.Value) & "," & Dn.Offset(, 6).Value
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
c = 1
[COLOR=navy]With[/COLOR] Sheets("Sheet2")
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] Dic.keys
        c = c + 1
        .Cells(c, 1).Value = K
        Sp = Split(Dic(K), ",")
       .Cells(c, 2).Resize(, UBound(Sp) + 1).Value = Sp
    [COLOR=navy]Next[/COLOR] K
[COLOR=navy]End[/COLOR] With
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[Wills1971]

Hi Mick,
Many thanks for your quick reply and your code works perfectly

Can I ask you to make an amendment to it. Each person has their date of birth in column C on sheet1 I would like to copy their D.O.B and paste it in to cell B2 on sheet2 and then have the values in each cell after that in row 2 and repeat this for every person adding their D.O.B.

Also, if in the future I wanted to copy the data under one of the other headings and add it to sheet2 for example the information in column F from sheet1 and paste it in to cell C2 on sheet2 and then have the values in each cell after that in row 2, how could I do this?

Again Mick many thanks for your help it is greatly appreciated

Will

 

[MickG]

Try this:-
(See Code Notes)

[COLOR=navy]Sub[/COLOR] MG25Jan00
[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] Dic [COLOR=navy]As[/COLOR] Object
[COLOR=navy]Dim[/COLOR] Sp [COLOR=navy]As[/COLOR] Variant, K [COLOR=navy]As[/COLOR] Variant, c [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Q [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
[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 Dic.exists(Dn.Value) [COLOR=navy]Then[/COLOR]
       '[COLOR=green][B](1) Now stored below is range Object "Dn" as well as dn.offset(,6).value)"[/B][/COLOR]
        Dic.Add Dn.Value, Array(Dn, Dn.Offset(, 6).Value)
    [COLOR=navy]Else[/COLOR]
        Q = Dic(Dn.Value)
        Q(1) = Q(1) & "," & Dn.Offset(, 6).Value
        Dic(Dn.Value) = Q
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
c = 1
[COLOR=navy]With[/COLOR] Sheets("Sheet13")
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] Dic.keys
        c = c + 1
        .Cells(c, 1).Value = K
        '[COLOR=green][B]Because the Dictionary now stores the Range Object of "Dn" (see(1))[/B][/COLOR]
        '[COLOR=green][B] you can get  any cell value from that row, as shown below[/B][/COLOR]
        '[COLOR=green][B] The "D.O.B" columns "C" is shown below as:-[/B][/COLOR]
        '[COLOR=green][B]Dic(k)(0) is the first Item in the array at (1) i.e "Dn"[/B][/COLOR]
        '[COLOR=green][B] as Column "C" is one column over, then:-Dic(K)(0).Offset(, 1).Value[/B][/COLOR]
        '[COLOR=green][B] is the "D.O.B"[/B][/COLOR]
        '[COLOR=green][B]Modify line below for othe row values.[/B][/COLOR]
        .Cells(c, 2).Value = Dic(K)(0).Offset(, 1).Value
        Sp = Split(Dic(K)(1), ",")
       
       .Cells(c, 3).Resize(, UBound(Sp) + 1).Value = Sp
    [COLOR=navy]Next[/COLOR] K
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[MickG]

Please correct error in code:-
From

[COLOR=#000080]With[/COLOR] Sheets("Sheet13")
'to
[COLOR=#000080]With[/COLOR] Sheets("Sheet2")

 

[Wills1971]

Hi Mick,
Once again thank you very much, your code works perfect and for taking the time to explain it


I added in another if statement to copy up the next column, I, after the value column, H, as in the code below using the Dn.Offset(, 7).value

For Each Dn In Rng
    If Not Dic.exists(Dn.Value) Then
       Dic.Add Dn.Value, Array(Dn, Dn.Offset(, 6).Value)
    Else
        Q = Dic(Dn.Value)
        Q(1) = Q(1) & "," & Dn.Offset(, 6).Value
        Dic(Dn.Value) = Q
    End If
    
    If Not Dic.exists(Dn.Value) Then
       Dic.Add Dn.Value, Array(Dn, Dn.Offset(, 7).Value)
    Else
        Q = Dic(Dn.Value)
        Q(1) = Q(1) & "," & Dn.Offset(, 7).Value
        Dic(Dn.Value) = Q
    End If

Column H on sheet1 is the values that have been put in to the row for each person they are called SA values. Column I on sheet1 is a date associated with the SA value called SA Date.

So now on sheet2 I have in column A cell A2 the persons D.O.B, in column B cell B2 their name, in column C cell C2 the 1st SA value, in column D cell D2 the date associated with the first SA value, SA Date, in column E cell E2 is the 2nd SA value, in column F cell F2 is the 2nd SA Date etc. Then the next persons details go in row 3, their D.O.B in A3, Name in B3, SA value in C3, SA Date in D3, E3 is the 2nd SA value, F3 is the 2nd SA Date etc.

Is there a way to add headings for the SA value columns i.e columns C, E, G, I, K etc. every time a SA value is entered? The heading, called SA VALUE, would be in row1 of sheet2 e.g. cell C1, E1, G1, I1, K1 etc.

Also do the same for each time a date is added for the SA DATE values again going in sheet2 row1 e.g. cells D1, F1, H1, J1,L1 etc.

Again Many thanks in advance Mick if this is possible and for all your help
Much appreciated,
Will

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG26Jan47
'[COLOR="Green"][B]MKII[/B][/COLOR]
[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] Dic [COLOR="Navy"]As[/COLOR] Object, R [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
[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 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"]Next[/COLOR]
c = 1
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
        c = c + 1
        Ac = 4
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Dic(K)
            .Cells(1, 1).Value = "D.O.B"
            .Cells(c, 1).Value = R.Offset(, 1).Value
            .Cells(1, 2).Value = "Name"
            .Cells(c, 2).Value = R.Value
            .Cells(1, Ac - 1).Value = "SA Value"
            .Cells(c, Ac - 1).Value = R.Offset(, 6).Value
            .Cells(1, Ac).Value = "SA Date"
            .Cells(c, Ac).Value = R.Offset(, 7).Value
            Ac = Ac + 2
        oMax = Application.Max(oMax, Ac)
        [COLOR="Navy"]Next[/COLOR] R
    [COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]With[/COLOR] .Range("A1").Resize(c, oMax)
    .Borders.Weight = 2
    .Columns.AutoFit
    .HorizontalAlignment = xlCenter
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Wills1971]

Hi Mick,

Once again your code was perfect and worked a treat

Many many thanks for all your help

Will