Merge rows while taking the weighted averages for the new cell values

[engineerlady]

Ok, what I'm trying to do with a spreadsheet of tens of thousands of rows is the following:

Please see attached workbook, and the sheet called "Data"

1. If the value in column A is the same AND
2. the verb in column B is the same as the verb in the previous row, THEN
3. Merge the rows, while calculating the weighted average for columns C, D and E

This is illustrated on the sheet called "Desired Result".

For example, the new value for column C, row 3 is calculated using the following equation:

New weighted Time = average { (time1/average(time1, time 2, time 3))*time 1,
(time2/average(time1, time 2, time 3))*time 2,
(time3/average(time1, time 2, time 3))*time 3}

The new values in columns D and E are calculated similarly.

I've hit a wall with this and am not sure where to start with creating a macro.

Thank you.

[AlphaFrog]

In your desired results, why isn't B - Jump merged?

[engineerlady]

My apologies, I forgot to add that I don't want to merge all the rows with duplicate actions, just specific actions, in this case, walk, run and skip.

[AKK9]

This should work. It's not the fastest thing in the world and maybe the code is a bit sloppy but here you go. It does about 100,000 rows in about 10 seconds. Hope this helps.

Here's the code:

Please Login or Register  to view this content.

[AlphaFrog]

Another method...

Please Login or Register  to view this content.

[engineerlady]

AlphaFrog...you are amazing!!! Thank you so much for taking the time to write the code for my problem!!!! I'm so appreciative, it works perfectly! Thank you!!!!!

[AlphaFrog]

You're welcome.

One small code change. Change this...
For i = 2 To UBound(data, 1) - 1
To this...
For i = 2 To UBound(data, 1)

Also, though you chose to use my version, AKK9 deserves a little love as well.

[AKK9]

I'll see myself out.....

Also, AlphaFrog what are these?

Please Login or Register  to view this content.

Never seen these before.

[AlphaFrog]

Also, AlphaFrog what are these?

Please Login or Register  to view this content.

Datatype Abbreviations / Suffixes

% = integer
& = long
! = single
# = double
@ = currency
$ = string
Variant is the default datatype if not defined

Example:
This..
Dim i As Long
Is the same as this...
Dim i&

[engineerlady]

WOW, AKK9, you are really good too!! Thank you also! Both of you are really good!

They both work perfectly. However, I've got an issue with my data, it turns out that the values in column A are not unique, therefore I need to check another column in addition to column A. (Sorry to throw a wrench in this...) I added column B and named it "Number".

Category Number Action Time Route Length
A 1 Run 7 1 0.2
A 1 Walk 10 5 0.35
A 1 Walk 12 4 0.4
A 1 Walk 9 2 0.6
A 1 Skip 13 3 0.25
B 2 Walk 15 3 0.46
B 2 Jump 14 2 0.78
B 2 Jump 16 2 0.15
B 2 Skip 8 1 0.55
C 3 Run 7 4 0.3
C 3 Run 7 5 0.7
C 3 Walk 13 5 0.55
C 3 Skip 10 2 0.25
C 3 Skip 10 1 0.4


I tried to change AKK9's code to accomodate another column to check, but am at a loss.


Sub combine_dupes()

Dim lRow As Long, sCat As String, sAction As String, sNumb As String, lRow2 As Single, lTime As Single, lGroup As Single
Dim dTime() As Single, dTime2() As Single
Dim dRoute() As Single, dRoute2() As Single
Dim dLen() As Single, dLen2() As Single
Dim newWS As Worksheet, thisWS As Worksheet

Application.ScreenUpdating = False

Set thisWS = ThisWorkbook.ActiveSheet
Set newWS = ThisWorkbook.Sheets.Add

lRow2 = 2
lRow = 2
sCat = thisWS.Cells(lRow, 1).Value
sNumb = thisWS.Cells(1Row, 2).Value
sAction = thisWS.Cells(lRow, 3).Value
Group = 1
ReDim dTime(1 To 1)
ReDim dRoute(1 To 1)
ReDim dLen(1 To 1)
dTime(lGroup) = thisWS.Cells(lRow, 4).Value
dRoute(lGroup) = thisWS.Cells(lRow, 5).Value
dLen(lGroup) = thisWS.Cells(lRow, 6).Value

With thisWS
Do
lRow = lRow + 1
If .Cells(lRow, 1).Value = sCat And .Cells(1Row, 2).Value = sNumb And .Cells(lRow, 3).Value = sAction And _
(sAction = "Walk" Or sAction = "Run" Or sAction = "Skip") Then
lGroup = lGroup + 1
ReDim Preserve dTime(1 To lGroup)
ReDim Preserve dRoute(1 To lGroup)
ReDim Preserve dLen(1 To lGroup)
dTime(lGroup) = .Cells(lRow, 3).Value
dRoute(lGroup) = .Cells(lRow, 4).Value
dLen(lGroup) = .Cells(lRow, 5).Value
Else
If lGroup = 1 Then
newWS.Range(newWS.Cells(lRow2, 1), newWS.Cells(lRow2, 6)).Value = _
.Range(.Cells(lRow - 1, 1), .Cells(lRow - 1, 6)).Value
lRow2 = lRow2 + 1
Else
newWS.Cells(lRow2, 1).Value = sCat
newWS.Cells(1Row2, 2).Value = sNumb
newWS.Cells(lRow2, 3).Value = sAction
ReDim dTime2(1 To lGroup)
ReDim dRoute2(1 To lGroup)
ReDim dLen2(1 To lGroup)
For i = 1 To lGroup
dTime2(i) = (dTime(i) / WorksheetFunction.Average(dTime)) * dTime(i)
dRoute2(i) = (dRoute(i) / WorksheetFunction.Average(dRoute)) * dRoute(i)
dLen2(i) = (dLen(i) / WorksheetFunction.Average(dLen)) * dLen(i)
Next i
newWS.Cells(lRow2, 4).Value = WorksheetFunction.Average(dTime2)
newWS.Cells(lRow2, 5).Value = WorksheetFunction.Average(dRoute2)
newWS.Cells(lRow2, 6).Value = WorksheetFunction.Average(dLen2)
Erase dTime2
Erase dRoute2
Erase dLen2
lRow2 = lRow2 + 1
lGroup = 1
End If
sCat = thisWS.Cells(lRow, 1).Value
sNumb = thisWS.Cells(1Row, 2).Value
sAction = thisWS.Cells(lRow, 3).Value
ReDim dTime(1 To lGroup)
ReDim dRoute(1 To lGroup)
ReDim dLen(1 To lGroup)
dTime(lGroup) = .Cells(lRow, 4).Value
dRoute(lGroup) = .Cells(lRow, 5).Value
dLen(lGroup) = .Cells(lRow, 6).Value
End If
Loop Until .Cells(lRow, 1).Value = ""
End With

Application.ScreenUpdating = True

End Sub

You'll see the errors if you paste into excel.
Thank you.