Results 1 to 9 of 9

Thread: VBA To Extract Data From Multiple Tables Based On Critera

Hybrid View

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

    VBA To Extract Data From Multiple Tables Based On Critera

    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.
    Attached Files Attached Files

  2. #2
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    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
    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
    Junior Member
    Join Date
    May 2013
    Posts
    20
    Rep Power
    0
    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
    Last edited by aaronb; 05-20-2013 at 02:56 PM.

  4. #4
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    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
    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
    Yup it works. Thanks again

  6. #6
    Junior Member
    Join Date
    May 2013
    Posts
    20
    Rep Power
    0
    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
    Last edited by aaronb; 05-31-2013 at 05:44 AM.

  7. #7
    Junior Member
    Join Date
    May 2013
    Posts
    20
    Rep Power
    0
    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
    Last edited by aaronb; 06-01-2013 at 03:15 AM.

  8. #8
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    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.
    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
    Junior Member
    Join Date
    May 2013
    Posts
    20
    Rep Power
    0
    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.

Similar Threads

  1. Replies: 17
    Last Post: 05-22-2013, 11:58 PM
  2. Replies: 2
    Last Post: 03-05-2013, 07:34 AM
  3. VBA Code to Extract data
    By Howardc in forum Excel Help
    Replies: 1
    Last Post: 07-24-2012, 11:37 PM
  4. Replies: 7
    Last Post: 03-06-2012, 07:49 AM
  5. Extract multiple data matching with input
    By excel_learner in forum Excel Help
    Replies: 1
    Last Post: 02-13-2012, 06:08 PM

Tags for this Thread

Posting Permissions

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