Results 1 to 10 of 10

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

  1. #1
    Junior Member
    Join Date
    May 2013
    Posts
    20
    Rep Power
    0

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

    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

  2. #2
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    OK, working on this

    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    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.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.9BLeCWVhxdG9wgNPOdiDuv
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgN7AC7wAc
    https://www.youtube.com/watch?v=bs-urI_o8jo&lc=UgyBACXgNY4j_cHgH5J4AaABAg.9oTkVdzfqfm 9wlhQrYJP3M
    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=GqzeFYWjTxI&lc=UgxvxlnuTRWiV6MUZB14AaABAg
    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=Ugz5DDCMqmHLeEjUU8t4AaABAg. 9bl7m03Onql9xI-ar3Z0ME
    https://www.youtube.com/watch?v=0ltJS7uHfK4&lc=UgxYnpd9leriPmc8rPd4AaABAg. 9gdrYDocLIm9xI-2ZpVF-q
    https://www.youtube.com/watch?v=0ltJS7uHfK4&lc=UgyjoPLjNeIAOMVH_u94AaABAg. 9id_Q3FO8Lp9xHyeYSuv1I
    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=UgyBACXgNY4j_cHgH5J4AaABAg.9oTkVdzfqfm 9wlhQrYJP3M
    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. 9wdo_rWgxSH9wdpcYqrvp8
    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=UgxBU39bTptFznDC1PJ4AaABAg
    ttps://www.youtube.com/watch?v=GqzeFYWjTxI
    https://www.youtube.com/watch?v=GqzeFYWjTxI&lc=UgwJnJDJ5JT8hFvibt14AaABAg
    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    Last edited by DocAElstein; 11-30-2023 at 02:46 PM.
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  3. #3
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    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?
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  4. #4
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    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
    Attached Files Attached Files
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  5. #5
    Junior Member
    Join Date
    May 2013
    Posts
    20
    Rep Power
    0
    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?

  6. #6
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    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
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  7. #7
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    Payment received
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  8. #8
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    Got your PM on keeping the list order untouched, and using the same table. Will work on it tomorrow and get back.
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  9. #9
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    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
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  10. #10
    Junior Member
    Join Date
    May 2013
    Posts
    20
    Rep Power
    0
    Wonderful, exactly what I was looking for. Thanks a lot

Similar Threads

  1. Replies: 25
    Last Post: 08-02-2013, 07:23 AM
  2. Replies: 4
    Last Post: 06-18-2013, 01:38 PM
  3. Email merge unique messages to groups and individuals
    By RagingWahoo in forum Excel Help
    Replies: 3
    Last Post: 10-14-2012, 11:32 PM
  4. Replies: 9
    Last Post: 03-13-2012, 01:27 PM
  5. Merge Multiple Worksheets into One
    By Rasm in forum Excel Help
    Replies: 2
    Last Post: 05-04-2011, 04:15 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •