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

**aaronb** · 08-17-2013, 01:01 PM

Description: http://www.excelfox.com/forum/f2/vba...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** · 08-17-2013, 10:55 PM

**Excel Fox** · 08-18-2013, 05:24 PM

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** · 08-18-2013, 08:56 PM

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.

Code:

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).Resize(.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** · 08-18-2013, 11:18 PM

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** · 08-19-2013, 11:53 PM

Code:

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).Resize(.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** · 08-20-2013, 12:31 AM

Payment received

**Excel Fox** · 08-20-2013, 02:43 AM

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

**Excel Fox** · 08-20-2013, 06:11 PM

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

Code:

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