VBA To Extract Data From Multiple Tables Based On Critera

[aaronb]

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:

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