Looping through data and assigning data to a dictionary value

Hi all,

I'll try to give a clear explanation of what I'm trying to do, and then will copy my code.

I have a data set with multiple rows per item. I want to end with one row per item, in addition to some new columns which are essentially countifs of some of the original columns.

My data starts on a tab called "Data Set 1 Hidden" and I've copied this to sheet "Data Set 1" where I remove duplicates, after creating a strong unique identifier. Ultimately, I want to append the entries in my dictionary to my "Data Set 1" tab, so I end with one row per unique item, with additional columns at the end.

Formula:

Sub calculation()



    'Define variables needed

    Dim Calculations As Dictionary

    Dim lrowpre As Long, lrowpost As Long, i As Long

    Dim r As Range

    Dim c As Details

    

    Set Calculations = New Dictionary

    

    'Delete old data

    Application.DisplayAlerts = False

    On Error Resume Next

    Sheets("Data Set 1").Delete

    Application.DisplayAlerts = True

    

    Sheets("Data Set 1 Hidden").Activate

    

    'Find last row

    lrowpre = Range("A1", Range("A1").End(xlDown)).Count

       

    'Create unique key - to be deleted at end

        Columns(1).Insert

        Cells(1, 1) = "Unique key"

    

        For i = 1 To lrowpre

            

            Cells(i, 1) = Cells(i, 2) & "-" & Cells(i, 11)

        

        Next i

    

    'Copy the data to a new sheet, and there remove duplicates

        ActiveSheet.Copy After:=ActiveSheet

        ActiveSheet.Name = "Data Set 1"

        

        Range("A1", Range("A1").End(xlToRight).End(xlDown)).RemoveDuplicates Columns:=Array(1)

    

    'Find last row

    lrowpost = Range("A1", Range("A1").End(xlDown)).Count

    

    Sheets("Data Set 1 Hidden").Activate

    

    'Set variable to contain various bits of details

    For Each r In Range("A2", Range("A1").End(xlDown))

    

        Set c = New Details



        c.Unique_Key = r.Value

        c.New_Column= 0



        Calculations.Add c, c.New_Column



        Set c = Nothing

        

    Next r

    

    Sheets("Data Set 1 Hidden").Activate

        

    For i = 2 To lrowpost

        

        If Cells(i, 31) = 1 And Cells(i, 32) = 1 Then

        

            Calculations(Cells(i, 1)).New_Column.Value = Calculations(Cells(i, 1)).New_Column.Value + 1 '

        

        End If

    

    Next i

    

    'Delete temporary unique key

    Sheets("Data Set 1 Hidden").Activate

    Columns(1).Delete

    

End Sub

I'm failing on the last bit where I update the New_Column for each item in the dictionary.

If anyone can see what I've done wrong, I'd really appreciate that!

Thanks