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
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
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?
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
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?
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
Payment received
Got your PM on keeping the list order untouched, and using the same table. Will work on it tomorrow and get back.
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
Wonderful, exactly what I was looking for. Thanks a lot