VBA To Extract Data From Multiple Tables Based On Critera

**aaronb** · 05-20-2013, 07:45 AM

This wasn't getting too much love in my thread R.E. another issue so I'm posting it titled appropriately.

Essentially, what I am trying to do is get an automated way to copy all unique stock names and associated account names from two source tables in alphabetical order, without duplicates, to a final table. The stock names come from two sources: a positions table, and a history table.

Criteria:

1) It should only get stocks for accounts that exist in the Accounts Table (applies to the next two criteria).

2) It should only get stocks from the Positions table from the predefined quarter/year (in the workbook, $O$17 and $O$18)

3) It should only get stocks from the History table if the transaction quarter/year match the predefined quarter/year. If the stock has a settlement quarter listed, it should only grab the stock if those numbers (rather than the transaction quarter/year numbers) match the predefined quarter/year.

I'm sure that doesn't make 100% sense so please see the attached workbook. I have an example Position table, History table, Accounts table, and what the final result table should look like. After looking at it, everything should be very clear.

Thank you very much! I can work my way around formulas but VBA is a whole other ballpark for me and this is much needed.

**Excel Fox** · 05-20-2013, 10:06 AM

Code:

Sub Consolidator()

    Dim rngPosition As Range, rngAccounts As Range, rngHistory As Range
    Dim rngA As Range, rngP As Range, rngH As Range
    Dim strPeriodCriteria As String
    Dim objDic As Object: Set objDic = CreateObject("Scripting.Dictionary") ' New Dictionary
    With Worksheets("Sheet1")
        Set rngPosition = .Range("SamplePositions")
        Set rngAccounts = .Range("SampleAccounts")
        Set rngHistory = .Range("SampleHistory")
        strPeriodCriteria = .Range("O17").Value & .Range("O18").Value
        For Each rngA In rngAccounts.Columns(1).Cells
            For Each rngP In rngPosition.Columns(1).Cells
                If rngP.Value = rngA.Value Then
                    If rngP.Offset(, 2).Value & rngP.Offset(, 3).Value = strPeriodCriteria Then
                        objDic.Item(rngP.Value & "|" & rngP.Offset(, 1).Value) = 0
                    End If
                End If
            Next rngP
            For Each rngH In rngHistory.Columns(1).Cells
                If rngH.Value = rngA.Value Then
                    If Replace(Mid(rngH.Offset(, 4), 2), " ", "") = strPeriodCriteria Then
                        objDic.Item(rngH.Value & "|" & rngH.Offset(, 1).Value) = 0
                    ElseIf rngH.Offset(, 2).Value & rngH.Offset(, 3).Value & Replace(Mid(rngH.Offset(, 4), 2), " ", "") = strPeriodCriteria Then
                        objDic.Item(rngH.Value & "|" & rngH.Offset(, 1).Value) = 0
                    End If
                End If
            Next rngH
        Next rngA
        .Range("Original").Offset(1).ClearContents
        .ListObjects("Original").Resize .Range("$A$1:$D$2")
        .Range("Original").Range("A1").Resize(objDic.Count).Value = Application.Transpose(objDic.Keys)
        Application.DisplayAlerts = 0
        .Range("Original").Columns(1).Cells.TextToColumns _
                                Destination:=.Range("A2"), _
                                DataType:=xlDelimited, _
                                TextQualifier:=xlDoubleQuote, _
                                ConsecutiveDelimiter:=False, _
                                Tab:=True, _
                                Semicolon:=False, _
                                Comma:=False, Space:=False, _
                                Other:=True, OtherChar:="|", _
                                FieldInfo:=Array(Array(1, 1), Array(2, 1)), _
                                TrailingMinusNumbers:=True
        Application.DisplayAlerts = 1
    End With
    
End Sub

**aaronb** · 05-20-2013, 02:45 PM

EDIT: Ignore the rest, I got it working. I think I was just missing the quarter/year reference. Not sure how it worked up through getting the stocks with that in mind but I'm just glad it works now, heh. Thank you very much!

That worked great for my sample worksheet, thank you very much. I added some stuff to sort it at the end.

However, when I tried to transfer it to my actual project and changed all the cell/table references, it broke (sorry, shouldn't have overestimated my ability to tinker with it, heh). It works through grabbing all the names but throws an error when splitting the | separated account/stock names. I stepped through it, and it seems to be because it's pasting the data into column E instead of column C. When I kept the table in A:D, it worked correctly and pasted everything in column A then split it out so that's why I'm confused..

"Orig" table is C1:F2 (row 2 blank).

Here's what I have now:

Code:

Sub Consolidator()

Dim rngPosition As Range, rngAccounts As Range, rngHistory As Range
    Dim rngA As Range, rngP As Range, rngH As Range
    Dim strPeriodCriteria As String
    Dim objDic As Object: Set objDic = CreateObject("Scripting.Dictionary") ' New Dictionary
    With Worksheets("Sheet5")
        Set rngPosition = ThisWorkbook.Sheets("All Positions, All Accounts Mar").Range("PositionsTable")
        Set rngAccounts = .Range("SampAccounts")
        Set rngHistory = ThisWorkbook.Sheets("ALL HISTORY, ALL ACCOUNTS").Range("History")
        strPeriodCriteria = .Range("A6").Value & .Range("A7").Value
        For Each rngA In rngAccounts.Columns(1).Cells
            For Each rngP In rngPosition.Columns(5).Cells
                If rngP.Value = rngA.Value Then
                    If rngP.Offset(, 13).Value & rngP.Offset(, 15).Value = strPeriodCriteria Then
                        objDic.Item(rngP.Value & "|" & rngP.Offset(, 3).Value) = 0
                    End If
                End If
            Next rngP
            For Each rngH In rngHistory.Columns(6).Cells
                If rngH.Value = rngA.Value Then
                    If Replace(Mid(rngH.Offset(, 17), 2), " ", "") = strPeriodCriteria Then
                        objDic.Item(rngH.Value & "|" & rngH.Offset(, 1).Value) = 0
                    ElseIf rngH.Offset(, 15).Value & rngH.Offset(, 16).Value & Replace(Mid(rngH.Offset(, 17), 2), " ", "") = strPeriodCriteria Then
                        objDic.Item(rngH.Value & "|" & rngH.Offset(, 1).Value) = 0
                    End If
                End If
            Next rngH
        Next rngA
        .Range("Orig").Offset(1).ClearContents
        .ListObjects("Orig").Resize .Range("$C$1:$F$2")
        .Range("Orig").Range("C1").Resize(objDic.Count).Value = Application.Transpose(objDic.Keys)
        Application.DisplayAlerts = 0
        .Range("Orig").Columns(1).Cells.TextToColumns _
                                Destination:=.Range("C2"), _
                                DataType:=xlDelimited, _
                                TextQualifier:=xlDoubleQuote, _
                                ConsecutiveDelimiter:=False, _
                                Tab:=True, _
                                Semicolon:=False, _
                                Comma:=False, Space:=False, _
                                Other:=True, OtherChar:="|", _
                                FieldInfo:=Array(Array(1, 1), Array(2, 1)), _
                                TrailingMinusNumbers:=True
        Application.DisplayAlerts = 1
    End With
    
    ActiveWorkbook.Worksheets("Sheet5").ListObjects("Orig").Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("Sheet5").ListObjects("Orig").Sort.SortFields. _
        Add Key:=Range("Orig[Account]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet5").ListObjects("Orig").Sort.SortFields. _
        Add Key:=Range("Orig[Stock]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet5").ListObjects("Orig").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub

Thanks for your assistance

**Excel Fox** · 05-20-2013, 03:29 PM

So you've got it working now or not?

By the way, the sorting can be done like so...

Code:

    With Worksheets("Sheet5").ListObjects("Orig").Sort        .SortFields.Clear
        .SortFields.Add Key:=Range("Orig[Account]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("Orig[Stock]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

**aaronb** · 05-20-2013, 09:58 PM

Yup it works. Thanks again

**aaronb** · 05-31-2013, 04:37 AM

So I have made a few changes (highlighted) since I got the code from you, and it's mostly working but I got a couple issues.

1) I do a find/replace in Column B to clear the contents of any cell in Column B (Position column of Orig table) that has the text *EXCHANGED in it. One time when I ran the macro (no change in code from what you see) it did the find/replace OUTSIDE of the worksheet and overwrote a bunch of my source data. Fortunately I had a backup and it doesn't seem to be doing that anymore, but I need to make absolutely sure it's not going to do that again.

2) After the find/replace is done I delete table rows with blank cells in Position column of the table ("B:B"). This targets the rows that were *EXCHANGED positions, as well as positions that were blank to begin with (that's normal). It works, except when no rows with blank cells in the column were found, in which case it deletes the entire table data..!

Also, it's gotten much slower after my changes, not sure the cause. I turned off screen updating to try to shorten that time but it doesn't have much effect. Maybe there's a more optimized way to do what I did that you can show me. The Orig table will usually be <100 rows.

My (significant) changes are in bold (might have to quote it to see it since it's wrapped in code tags). Thanks!!

EDIT:: I realized that it is slow and find/replaces throughout the ENTIRE WORKBOOK when it is set to search within Workbook (instead of Sheet) in Control-F find and replace options. So, I want it to ignore that setting and only do the find/replacing in Column B of the active worksheet (or even better, column name "Position" of table "Orig").

Code:

Sub Consolidator()

Application.ScreenUpdating = False

Dim rngPosition As Range, rngAccounts As Range, rngHistory As Range
    Dim rngA As Range, rngP As Range, rngH As Range
    Dim strPeriodCriteria As String, strPreQCriteria As String
    Dim objDic As Object: Set objDic = CreateObject("Scripting.Dictionary") ' New Dictionary
    With Worksheets("Sheet5")
        Set rngPosition = ThisWorkbook.Sheets("All Positions, All Accounts Mar").Range("PositionsTable")
        Set rngAccounts = .Range("SampAccounts")
        Set rngHistory = ThisWorkbook.Sheets("ALL HISTORY, ALL ACCOUNTS").Range("History")
        strPeriodCriteria = .Range("B1").Value & .Range("B2").Value
        If .Range("B1").Value = 1 Then
            strPreQCriteria = "4" & .Range("B2").Value - 1
        Else
            strPreQCriteria = .Range("B1").Value - 1 & .Range("B2").Value
        End If
        For Each rngA In rngAccounts.Columns(1).Cells
            For Each rngP In rngPosition.Columns(5).Cells
                If rngP.Value = rngA.Value Then
                    If rngP.Offset(, 13).Value & rngP.Offset(, 15).Value = strPeriodCriteria Then
                        objDic.Item(rngP.Value & "|" & rngP.Offset(, 3).Value) = 0
                    ElseIf rngP.Offset(, 13).Value & rngP.Offset(, 15).Value = strPreQCriteria Then
                        objDic.Item(rngP.Value & "|" & rngP.Offset(, 3).Value) = 0
                    End If
                End If
            Next rngP
            For Each rngH In rngHistory.Columns(6).Cells
                If rngH.Value = rngA.Value Then
                    If Replace(Mid(rngH.Offset(, 18), 2), " ", "") = strPeriodCriteria Then
                        objDic.Item(rngH.Value & "|" & rngH.Offset(, 1).Value) = 0
                    ElseIf rngH.Offset(, 16).Value & rngH.Offset(, 17).Value & Replace(Mid(rngH.Offset(, 18), 2), " ", "") = strPeriodCriteria Then
                        objDic.Item(rngH.Value & "|" & rngH.Offset(, 1).Value) = 0
                    End If
                End If
            Next rngH
        Next rngA
        .Range("Orig").Offset(1).ClearContents
        .ListObjects("Orig").Resize .Range("$A$5:$I$6")
        .Range("Orig").Range("A1").Resize(objDic.Count).Value = Application.Transpose(objDic.Keys)
        Application.DisplayAlerts = 0
        .Range("Orig").Columns(1).Cells.TextToColumns _
                                Destination:=.Range("A6"), _
                                DataType:=xlDelimited, _
                                TextQualifier:=xlDoubleQuote, _
                                ConsecutiveDelimiter:=False, _
                                Tab:=True, _
                                Semicolon:=False, _
                                Comma:=False, Space:=False, _
                                Other:=True, OtherChar:="|", _
                                FieldInfo:=Array(Array(1, 1), Array(2, 1)), _
                                TrailingMinusNumbers:=True
        Application.DisplayAlerts = 1
        
        Range("B:B").Replace "*~*EXCHANGED*", "", xlPart
        Range("B:B").Replace "CASH", "ZZZCASH", xlPart
    End With
    
    With Worksheets("Sheet5").ListObjects("Orig").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("Orig[Account]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("Orig[Position]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    With Worksheets("Sheet5")
    Range("B:B").Replace "ZZZCASH", "CASH", xlPart
    End With
    
    'With ActiveSheet.ListObjects("Orig")
        '.Range.AutoFilter Field:=2, Criteria1:="="
        '.DataBodyRange.EntireRow.Delete
        '.Range.AutoFilter Field:=2
    'End With
    
    Application.ScreenUpdating = True

End Sub

**aaronb** · 06-01-2013, 02:46 AM

Update: Kind of hacky, but I managed to limit the find/replace to the specific worksheet by doing this before the find/replaces:

Code:

Set Dummy = Worksheets(1).Range("A1:A1").Find("Dummy", LookIn:=xlValues)

Now, just need help on the deleting part, thanks

This also works for deleting if there are rows with blank values in Column 2 of the table, but throws an error if no blanks were found. Guess it just needs error checking?

Code:

Dim RngBlank As Range
    With ActiveSheet.ListObjects("Orig").Range
        .AutoFilter Field:=2, Criteria1:="="
        Set RngBlank = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        .AutoFilter
        RngBlank.Delete
    End With

Edit: Looks like I got it. If there's a better way to do it, please let me know.

Code:

With ActiveSheet.ListObjects("Orig")

        .Range.AutoFilter Field:=2, Criteria1:="="
        
        If .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1 > 0 Then
            .DataBodyRange.EntireRow.Delete
            .Range.AutoFilter Field:=2
        Else
            .Range.AutoFilter Field:=2
        End If
        
End With

**Excel Fox** · 06-01-2013, 01:01 PM

Glad you got it all working by yourself in the end. You could also try the

Code:

.SpecialCells(xlCellTypeBlanks).EntireRow.Delete

option. But just be sure what your doing.

**aaronb** · 06-08-2013, 01:24 PM

I was having trouble with the code you gave above and the routine I wrote. Both gave errors when deleting. After trying a lot of different ways I finally found something that works (deletes just the table row not entire sheet row, and no errors even if none are blank).

Code:

With Intersect(Columns("B"), ActiveSheet.ListObjects("Orig").Range)
    
    On Error Resume Next
    Intersect(ActiveSheet.ListObjects("Orig").Range, .SpecialCells(xlBlanks).EntireRow).Delete Shift:=xlUp
    On Error GoTo 0
    
End With

One more question if I may. Right now I do stuff like this:
Range("B:B").Replace "CASH", "ZZZCASH", xlPart

Is there a way to have it pull each "find" from a table column and the corresponding replace from a second column? Say table "Renames", columns "From" and "To". So it is easier to manage in the future.