VBA To Extract Data From Multiple Tables Based On Critera

[aaronb]

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").

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