15 US Dollars For Macro To Merge And Aggregate Data For Same Row Headers

[aaronb]

Description: http://www.excelfox.com/forum/f2/vba-help-merging-rows-in-table-that-meet-specific-criteria-1357/

I need this by the end of the day (US time) and will pay promptly via PayPal upon successfully testing the macro.

I require it to be flexible for if the mergers/name changes table grows and for example if multiple sets of rows need to be merged (multiple mergers in one quarter). And, please optimize the code as much as possible.

Thank you

[Excel Fox]

OK, working on this

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg (https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg)
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgNsaS3Lp1 (https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgNsaS3Lp1)
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgR1EPUkhw (https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgR1EPUkhw)
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgNe_XC-jK (https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgNe_XC-jK)
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgNPOdiDuv (https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgNPOdiDuv)
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgN7AC7wAc (https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgN7AC7wAc)
https://www.youtube.com/watch?v=bs-urI_o8jo&lc=UgyBACXgNY4j_cHgH5J4AaABAg.9oTkVdzfqfm9wlhQrYJP 3M (https://www.youtube.com/watch?v=bs-urI_o8jo&lc=UgyBACXgNY4j_cHgH5J4AaABAg.9oTkVdzfqfm9wlhQrYJP 3M)
https://www.youtube.com/watch?v=bs-urI_o8jo&lc=UgxYgiEZuS9I3xkjJv54AaABAg (https://www.youtube.com/watch?v=bs-urI_o8jo&lc=UgxYgiEZuS9I3xkjJv54AaABAg)
https://www.youtube.com/watch?v=DVFFApHzYVk&lc=Ugyi578yhj9zShmhuPl4AaABAg (https://www.youtube.com/watch?v=DVFFApHzYVk&lc=Ugyi578yhj9zShmhuPl4AaABAg)
https://www.youtube.com/watch?v=GqzeFYWjTxI&lc=UgxvxlnuTRWiV6MUZB14AaABAg (https://www.youtube.com/watch?v=GqzeFYWjTxI&lc=UgxvxlnuTRWiV6MUZB14AaABAg)
https://www.youtube.com/watch?v=_8i1fVEi5WY&lc=Ugz0ptwE5J-2CpX4Lzh4AaABAg (https://www.youtube.com/watch?v=_8i1fVEi5WY&lc=Ugz0ptwE5J-2CpX4Lzh4AaABAg)
https://www.youtube.com/watch?v=0ltJS7uHfK4&lc=UgxoHAw8RwR7VmyVBUt4AaABAg.9C-br0lEl8V9xI0_6pCaR9 (https://www.youtube.com/watch?v=0ltJS7uHfK4&lc=UgxoHAw8RwR7VmyVBUt4AaABAg.9C-br0lEl8V9xI0_6pCaR9)
https://www.youtube.com/watch?v=0ltJS7uHfK4&lc=Ugz5DDCMqmHLeEjUU8t4AaABAg.9bl7m03Onql9xI-ar3Z0ME (https://www.youtube.com/watch?v=0ltJS7uHfK4&lc=Ugz5DDCMqmHLeEjUU8t4AaABAg.9bl7m03Onql9xI-ar3Z0ME)
https://www.youtube.com/watch?v=0ltJS7uHfK4&lc=UgxYnpd9leriPmc8rPd4AaABAg.9gdrYDocLIm9xI-2ZpVF-q (https://www.youtube.com/watch?v=0ltJS7uHfK4&lc=UgxYnpd9leriPmc8rPd4AaABAg.9gdrYDocLIm9xI-2ZpVF-q)
https://www.youtube.com/watch?v=0ltJS7uHfK4&lc=UgyjoPLjNeIAOMVH_u94AaABAg.9id_Q3FO8Lp9xHyeYSuv 1I (https://www.youtube.com/watch?v=0ltJS7uHfK4&lc=UgyjoPLjNeIAOMVH_u94AaABAg.9id_Q3FO8Lp9xHyeYSuv 1I)
https://www.reddit.com/r/windowsxp/comments/pexq9q/comment/k81ybvj/?utm_source=reddit&utm_medium=web2x&context=3 (https://www.reddit.com/r/windowsxp/comments/pexq9q/comment/k81ybvj/?utm_source=reddit&utm_medium=web2x&context=3)
https://www.youtube.com/watch?v=bs-urI_o8jo&lc=UgxYgiEZuS9I3xkjJv54AaABAg (https://www.youtube.com/watch?v=bs-urI_o8jo&lc=UgxYgiEZuS9I3xkjJv54AaABAg)
https://www.youtube.com/watch?v=bs-urI_o8jo&lc=UgyBACXgNY4j_cHgH5J4AaABAg.9oTkVdzfqfm9wlhQrYJP 3M (https://www.youtube.com/watch?v=bs-urI_o8jo&lc=UgyBACXgNY4j_cHgH5J4AaABAg.9oTkVdzfqfm9wlhQrYJP 3M)
ttps://www.youtube.com/watch?v=LP9fz2DCMBE (ttps://www.youtube.com/watch?v=LP9fz2DCMBE)
https://www.youtube.com/watch?v=LP9fz2DCMBE&lc=UgzbPgJUMCztIOQDym14AaABAg (https://www.youtube.com/watch?v=LP9fz2DCMBE&lc=UgzbPgJUMCztIOQDym14AaABAg)
https://www.youtube.com/watch?v=LP9fz2DCMBE&lc=UgzbPgJUMCztIOQDym14AaABAg.9wdo_rWgxSH9wdpcYqrv p8 (https://www.youtube.com/watch?v=LP9fz2DCMBE&lc=UgzbPgJUMCztIOQDym14AaABAg.9wdo_rWgxSH9wdpcYqrv p8)
ttps://www.youtube.com/watch?v=bFxnXH4-L1A (ttps://www.youtube.com/watch?v=bFxnXH4-L1A)
https://www.youtube.com/watch?v=bFxnXH4-L1A&lc=UgxuODisjo6cvom7O-B4AaABAg.9w_AeS3JiK09wdi2XviwLG (https://www.youtube.com/watch?v=bFxnXH4-L1A&lc=UgxuODisjo6cvom7O-B4AaABAg.9w_AeS3JiK09wdi2XviwLG)
https://www.youtube.com/watch?v=bFxnXH4-L1A&lc=UgxBU39bTptFznDC1PJ4AaABAg (https://www.youtube.com/watch?v=bFxnXH4-L1A&lc=UgxBU39bTptFznDC1PJ4AaABAg)
ttps://www.youtube.com/watch?v=GqzeFYWjTxI (ttps://www.youtube.com/watch?v=GqzeFYWjTxI)
https://www.youtube.com/watch?v=GqzeFYWjTxI&lc=UgwJnJDJ5JT8hFvibt14AaABAg (https://www.youtube.com/watch?v=GqzeFYWjTxI&lc=UgwJnJDJ5JT8hFvibt14AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[Excel Fox]

Aaron, just wanted to check. Will the result table always be there, and be overwritten, or should that be created each time you run the macro?

[Excel Fox]

I've just assumed that you are OK with replacing the output table. So here's the file with the revised code, and also the code below for posterity.


Option Explicit

Sub Consolidator()

Dim varSource As Variant
Dim varChanges As Variant
Dim varOutput As Variant
Dim sngYearQuarter As Single
Dim wks As Worksheet
Dim lngChanges As Long
Dim lngSource As Long
Dim lngOutput As Long
Dim lstTable As ListObject
Dim strPivotDataRange As String

Application.ScreenUpdating = 0
Set wks = Worksheets("Sheet1")
With wks
On Error Resume Next
Set lstTable = .ListObjects("PortfolioTable2")
Err.Clear: On Error GoTo 0: On Error GoTo -1
If Not lstTable Is Nothing Then
.Range("PortfolioTable2").EntireColumn.Delete
End If
.Range("PortfolioTable").Rows(1).Offset(-1).Resize(3).Copy .Range("P3")
.ListObjects.Add(xlSrcRange, .Range("$P$3:$X$5"), , xlYes).Name = "PortfolioTable2"
sngYearQuarter = .Range("B2").Value & "." & .Range("B1").Value
varSource = .Range("PortfolioTable").Value2
varChanges = .Range("MergersTable").Value2
For lngChanges = LBound(varChanges) To UBound(varChanges)
'Assuming that even if the Year and Quarter is greater than that in the mergers table, it still needs to be considered
'If that's not the case, in the expression below, remove >= to =
If sngYearQuarter >= CSng(varChanges(lngChanges, 2) & Application.DecimalSeparator & varChanges(lngChanges, 1)) Then
For lngSource = LBound(varSource) To UBound(varSource)
If varSource(lngSource, 2) = varChanges(lngChanges, 3) Then
varSource(lngSource, 2) = varChanges(lngChanges, 4)
End If
Next lngSource
End If
Next lngChanges
.Range("P4").Resize(lngSource - 1, 9).Value = varSource
.Range("AA:AI").Delete
strPivotDataRange = CreatePiv
.Range("PortfolioTable2").Offset(1).ClearContents
.ListObjects("PortfolioTable2").Resize (.Range("PortfolioTable2").Rows(1).Offset(-1).Resize(2))
.Range("P4").Resize(.Range(strPivotDataRange).Rows.Count, .Range(strPivotDataRange).Columns.Count).Value = .Range(strPivotDataRange).Value
.Range(strPivotDataRange).EntireColumn.Delete
.Range("PortfolioTable2").Rows(1).Resize(2).Copy
.Range("PortfolioTable2").PasteSpecial Paste:=xlPasteFormats
varOutput = .Range("PortfolioTable2").Value2
Application.CutCopyMode = False
For lngOutput = LBound(varOutput) To UBound(varOutput)
If IsEmpty(varOutput(lngOutput, 1)) Then
varOutput(lngOutput, 1) = varOutput(lngOutput - 1, 1)
End If
Next lngOutput
.Range("PortfolioTable2").Value2 = varOutput
.UsedRange.EntireColumn.AutoFit
End With
Application.ScreenUpdating = 1

End Sub

Private Function CreatePiv() As String

Dim pvc As PivotCache
Dim pvt As PivotTable

With ThisWorkbook
Set pvc = .PivotCaches.Create(SourceType:=xlDatabase, SourceData:="PortfolioTable2", Version:=xlPivotTableVersion12)
Set pvt = pvc.CreatePivotTable(TableDestination:="Sheet1!R2C27", TableName:="PvtCustom", DefaultVersion:=xlPivotTableVersion12)
End With
With pvt.PivotFields("Account")
.Orientation = xlRowField
.Position = 1
.Subtotals(1) = False
End With
With pvt.PivotFields("Position")
.Orientation = xlRowField
.Position = 2
.Subtotals(1) = False
End With
With pvt
.AddDataField .PivotFields("Col3"), "Col_3", xlSum
.AddDataField .PivotFields("Col4"), "Col_4", xlSum
.AddDataField .PivotFields("Col5"), "Col_5", xlSum
.AddDataField .PivotFields("Col6"), "Col_6", xlSum
.AddDataField .PivotFields("Col7"), "Col_7", xlSum
.AddDataField .PivotFields("Col8"), "Col_8", xlSum
.AddDataField .PivotFields("Col9"), "Col_9", xlSum
.InGridDropZones = True
.RowAxisLayout xlTabularRow
.ColumnGrand = False
.RowGrand = False
.ShowTableStyleColumnHeaders = False
.ShowTableStyleRowHeaders = False
CreatePiv = .TableRange1.Offset(.ColumnRange.Rows.Count).Resiz e(.TableRange1.Rows.Count - .ColumnRange.Rows.Count).Address
'Same Thing
'CreatePiv = .DataBodyRange.Offset(, -(.RowRange.Columns.Count)).Resize(, .DataBodyRange.Columns.Count + .RowRange.Columns.Count).Address
End With

End Function

[aaronb]

If my instructions were unclear I am sorry but the goal of the macro is to edit PortfolioTable (and PortfolioTable2 is just there to show what PortfolioTable should look like after the merging is complete). Also can you make it so it doesn't re-sort the rows?

[Excel Fox]

Option Explicit

Sub Consolidator()

Dim varSource As Variant
Dim varChanges As Variant
Dim varOutput As Variant
Dim sngYearQuarter As Single
Dim wks As Worksheet
Dim lngChanges As Long
Dim lngSource As Long
Dim lngOutput As Long
Dim lstTable As ListObject
Dim strPivotDataRange As String

Application.ScreenUpdating = 0
Set wks = Worksheets("Sheet1")
With wks
On Error Resume Next
Set lstTable = .ListObjects("PortfolioTable2")
Err.Clear: On Error GoTo 0: On Error GoTo -1
If Not lstTable Is Nothing Then
.Range("PortfolioTable2").EntireColumn.Delete
End If
.Range("PortfolioTable").Rows(1).Offset(-1).Resize(3).Copy .Range("P3")
.ListObjects.Add(xlSrcRange, .Range("$P$3:$X$5"), , xlYes).Name = "PortfolioTable2"
sngYearQuarter = .Range("B2").Value & "." & .Range("B1").Value
varSource = .Range("PortfolioTable").Value2
varChanges = .Range("MergersTable").Value2
For lngChanges = LBound(varChanges) To UBound(varChanges)
'Assuming that even if the Year and Quarter is greater than that in the mergers table, it still needs to be considered
'If that's not the case, in the expression below, remove >= to =
If sngYearQuarter >= CSng(varChanges(lngChanges, 2) & Application.DecimalSeparator & varChanges(lngChanges, 1)) Then
For lngSource = LBound(varSource) To UBound(varSource)
If varSource(lngSource, 2) = varChanges(lngChanges, 3) Then
varSource(lngSource, 2) = varChanges(lngChanges, 4)
End If
Next lngSource
End If
Next lngChanges
.Range("P4").Resize(lngSource - 1, 9).Value = varSource
.Range("AA:AI").Delete
strPivotDataRange = CreatePiv
.Range("PortfolioTable2").Offset(1).ClearContents
.ListObjects("PortfolioTable2").Resize (.Range("PortfolioTable2").Rows(1).Offset(-1).Resize(2))
.Range("P4").Resize(.Range(strPivotDataRange).Rows.Count, .Range(strPivotDataRange).Columns.Count).Value = .Range(strPivotDataRange).Value
.Range(strPivotDataRange).EntireColumn.Delete
.Range("PortfolioTable2").Rows(1).Resize(2).Copy
.Range("PortfolioTable2").PasteSpecial Paste:=xlPasteFormats
varOutput = .Range("PortfolioTable2").Value2
Application.CutCopyMode = False
For lngOutput = LBound(varOutput) To UBound(varOutput)
If IsEmpty(varOutput(lngOutput, 1)) Then
varOutput(lngOutput, 1) = varOutput(lngOutput - 1, 1)
End If
Next lngOutput
.Range("PortfolioTable2").Value2 = varOutput
.Range("PortfolioTable").ClearContents
.ListObjects("PortfolioTable").Resize (.Range("PortfolioTable").Rows(1).Offset(-1).Resize(.Range("PortfolioTable").Rows.Count))
.Range("PortfolioTable").Value = varOutput
.Range("PortfolioTable2").EntireColumn.Delete
.UsedRange.EntireColumn.AutoFit
End With
Application.ScreenUpdating = 1

End Sub

Private Function CreatePiv() As String

Dim pvc As PivotCache
Dim pvt As PivotTable

With ThisWorkbook
Set pvc = .PivotCaches.Create(SourceType:=xlDatabase, SourceData:="PortfolioTable2", Version:=xlPivotTableVersion12)
Set pvt = pvc.CreatePivotTable(TableDestination:="Sheet1!R2C27", TableName:="PvtCustom", DefaultVersion:=xlPivotTableVersion12)
End With
With pvt.PivotFields("Account")
.Orientation = xlRowField
.Position = 1
.Subtotals(1) = False
End With
With pvt.PivotFields("Position")
.Orientation = xlRowField
.Position = 2
.Subtotals(1) = False
End With
With pvt
.AddDataField .PivotFields("Col3"), "Col_3", xlSum
.AddDataField .PivotFields("Col4"), "Col_4", xlSum
.AddDataField .PivotFields("Col5"), "Col_5", xlSum
.AddDataField .PivotFields("Col6"), "Col_6", xlSum
.AddDataField .PivotFields("Col7"), "Col_7", xlSum
.AddDataField .PivotFields("Col8"), "Col_8", xlSum
.AddDataField .PivotFields("Col9"), "Col_9", xlSum
.InGridDropZones = True
.RowAxisLayout xlTabularRow
.ColumnGrand = False
.RowGrand = False
.ShowTableStyleColumnHeaders = False
.ShowTableStyleRowHeaders = False
CreatePiv = .TableRange1.Offset(.ColumnRange.Rows.Count).Resiz e(.TableRange1.Rows.Count - .ColumnRange.Rows.Count).Address
'Same Thing
'CreatePiv = .DataBodyRange.Offset(, -(.RowRange.Columns.Count)).Resize(, .DataBodyRange.Columns.Count + .RowRange.Columns.Count).Address
End With

End Function

[Excel Fox]

Payment received

[Excel Fox]

Got your PM on keeping the list order untouched, and using the same table. Will work on it tomorrow and get back.

[Excel Fox]

Here's the revised code (actually, completely rebuilt)


Sub Condensor()

Dim varSource As Variant
Dim varMergers As Variant
Dim sngYearQuarter As Single
Dim lngMerger As Long
Dim lngSource As Long
Dim lngCol As Long
Dim lngPullUpRow As Long
Dim lngRowsReduced As Long
With Worksheets("Sheet1")
varSource = .Range("PortfolioTable").Value2
varMergers = .Range("MergersTable").Value2
sngYearQuarter = CSng(.Range("B2").Value & Application.DecimalSeparator & .Range("B1").Value)
For lngMerger = LBound(varMergers) To UBound(varMergers)
If sngYearQuarter = CSng(varMergers(lngMerger, 2) & Application.DecimalSeparator & varMergers(lngMerger, 1)) Then
For lngSource = LBound(varSource) To UBound(varSource)
If varMergers(lngMerger, 3) = varSource(lngSource, 2) Then
varSource(lngSource, 2) = varMergers(lngMerger, 4)
End If
Next lngSource
End If
Next lngMerger
.Range("PortfolioTable").Value2 = varSource
lngSource = .Range("PortfolioTable").Rows.Count
For lngSource = lngSource To 2 Step -1
For lngMerger = lngSource - 1 To 1 Step -1
If varSource(lngSource, 2) = varSource(lngMerger, 2) Then
lngRowsReduced = lngRowsReduced + 1
For lngCol = 3 To 9
varSource(lngMerger, lngCol) = varSource(lngMerger, lngCol) + varSource(lngSource, lngCol)
Next lngCol
For lngPullUpRow = lngSource To .Range("PortfolioTable").Rows.Count - 1
For lngCol = 1 To 9
varSource(lngPullUpRow, lngCol) = varSource(lngPullUpRow + 1, lngCol)
varSource(lngPullUpRow + 1, lngCol) = Empty
Next lngCol
Next lngPullUpRow

End If
Next lngMerger
Next lngSource
.Range("PortfolioTable").Value2 = varSource
With .ListObjects("PortfolioTable")
lngRowsReduced = .Range.Rows.Count - lngRowsReduced
.Resize (.Range.Resize(lngRowsReduced))
End With
End With

End Sub

[aaronb]

Wonderful, exactly what I was looking for. Thanks a lot