How to add a flag for filtering a dictionary etc.

[bradmsg]

ALL,

How can i add flags for filtering in this given my data structure? I would like to add flags for filtering certain records from shtMstr to other sheets.

for example:

After the code checks for Var(RPUID) in shtData and grabs related records from shtMstr

if Column P (date) is before the variable StartDate, flag

if column "I" in shtMstr starts with D20, Flag

Once the item is flagged, send to sheet("D20")

Is this possible?

Sub GetRPUID_Data()

    Dim shtData As Worksheet, shtMstr As Worksheet, shtOut As Worksheet
    Dim dataLastRow As Long, mstrLastRow As Long, mstrLastCol As Long
    Dim dataRng As Range, mstrRng As Range
    Dim dataArr As Variant, mstrArr As Variant, outArr As Variant
    Dim dictData As Object, dictKey As String
    Dim RPUID As Long
    Dim i As Long, iMstr As Long, jCol As Long, iOut As Long
    Dim StartDate as String

    StartDate = 1/13/2022

    
    Set shtData = Worksheets("Sheet1")              
    Set shtMstr = Worksheets("Sheet2")              
    Set shtOut = Worksheets("Sheet3")               
    
    With shtData
        dataLastRow = .Range("A" & Rows.Count).End(xlUp).row
        Set dataRng = .Range(.Cells(2, "A"), .Cells(dataLastRow, "A"))
        dataArr = dataRng.Value2
    End With
    
    With shtMstr
        mstrLastRow = .Range("A" & Rows.Count).End(xlUp).row
        mstrLastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        Set mstrRng = .Range(.Cells(4, "V"), .Cells(mstrLastRow, mstrLastCol))
        mstrArr = mstrRng.Value2
    End With
    
    ' Load shtData into Dictionary
    Set dictData = CreateObject("Scripting.dictionary")
    For i = 1 To UBound(dataArr)
        RPUID = dataArr(i, 1)
        dictKey = RPUID
        If Not dictData.Exists(dictKey) Then
            dictData(dictKey) = i               ' Actual value not required for this scenario ie "" or empty would work
        End If
    Next i
    
    ' Set up output array
        ReDim outArr(1 To UBound(mstrArr, 1), 1 To UBound(mstrArr, 2))
    ' Loop through master and capture lines found in shtData based on dictionary into output array
    For iMstr = 1 To UBound(mstrArr)
        RPUID = mstrArr(iMstr, 6)
        dictKey = RPUID
        
        If dictData.Exists(dictKey) Then                    ' Add any additional criteria here
            iOut = iOut + 1
            For jCol = 1 To UBound(mstrArr, 2)
                outArr(iOut, jCol) = mstrArr(iMstr, jCol)
            Next jCol
        End If
    Next iMstr

    ' Write back output array
    With shtOut
        .Range("A2").Resize(iOut, UBound(outArr, 2)).Value2 = outArr
        shtMstr.Range("A1").Resize(1, UBound(outArr, 2)).Copy Destination:=.Range("A1").Resize(1, UBound(outArr, 2))
        .Range("A2").Resize(iOut, UBound(outArr, 2)).EntireColumn.AutoFit
    End With

End Sub

 

[Alex Blakenburg]

Try this on a copy of your of your workbook.
It assumes Sheet D20 exists and is empty and that you are still using Sheet4 as part of the RPUIDs that you want to select.

Sub GetRPUID_FilterAndCopyData()

    Dim shtData As Worksheet, shtMstr As Worksheet, shtOut As Worksheet
    Dim dataLastRow As Long, mstrLastRow As Long, mstrLastCol As Long
    Dim dataRng As Range, mstrRng As Range
    Dim dataArr As Variant, mstrArr As Variant, outArr As Variant
    Dim dictData As Object, dictKey As String
    Dim RPUID As Long
    Dim i As Long, iMstr As Long, jCol As Long, iOut As Long
    Dim lngInspectDt As Long, strCategory As String, StartDate As Long, CatCriteria As String
    Dim mstrNextCol As Long
    
    StartDate = CLng(DateSerial(2023, 1, 18))       ' <--- Enter the date here or use a cell reference
    CatCriteria = "D20"
    
    Set shtData = Worksheets("Sheet4")              ' <--- Use real sheet name
    Set shtMstr = Worksheets("Master")              ' <--- Use real sheet name
    Set shtOut = Worksheets("D20")                  ' <--- Use real sheet name
    
    With shtData
        dataLastRow = .Range("A" & Rows.Count).End(xlUp).Row
        Set dataRng = .Range(.Cells(2, "A"), .Cells(dataLastRow, "A"))
        dataArr = dataRng.Value2
    End With
    
    With shtMstr
        If .FilterMode = True Then
            .ShowAllData
        End If
        mstrLastRow = .Range("A" & Rows.Count).End(xlUp).Row
        mstrLastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        mstrNextCol = mstrLastCol + 1
        Set mstrRng = .Range(.Cells(2, "A"), .Cells(mstrLastRow, mstrLastCol))
        mstrArr = mstrRng.Value2
    End With
    
    ' Load shtData into Dictionary
    Set dictData = CreateObject("Scripting.dictionary")
    For i = 1 To UBound(dataArr)
        RPUID = dataArr(i, 1)
        dictKey = RPUID
        If Not dictData.exists(dictKey) Then
            dictData(dictKey) = i               ' Actual value not required for this scenario ie "" or empty would work
        End If
    Next i
    
    ' Set up output array
        ReDim outArr(1 To UBound(mstrArr, 1), 1 To 1)           ' Array to flag selected items
    ' Loop through master and flag lines that meet the criteria
    For iMstr = 1 To UBound(mstrArr)
        RPUID = mstrArr(iMstr, 6)
        dictKey = RPUID
        lngInspectDt = mstrArr(iMstr, 16)
        strCategory = mstrArr(iMstr, 9)
        
        If dictData.exists(dictKey) Then
            If lngInspectDt < StartDate And _
                strCategory Like (CatCriteria & "*") Then       ' Add any additional criteria here
                    outArr(iMstr, 1) = 1                        ' Flag items to be selected
            End If
        End If
    Next iMstr

    ' Write back output array flag to next column
    mstrRng.Columns(mstrNextCol).Resize(, 1).Value = outArr
    
    If shtMstr.AutoFilterMode Then
         shtMstr.AutoFilterMode = False
    End If
    mstrRng.Resize(, mstrNextCol).AutoFilter Field:=mstrNextCol, Criteria1:="1"
    mstrRng.Copy
    shtOut.Range("A2").PasteSpecial Paste:=xlPasteValues
    shtOut.Range("A2").PasteSpecial Paste:=xlPasteFormats
    shtMstr.Rows(1).Copy Destination:=shtOut.Rows(1)
    shtOut.Range("A1").CurrentRegion.Columns.AutoFit
    mstrRng.Columns(mstrNextCol).EntireColumn.Delete

End Sub

 

[bradmsg]

Won’t be able to test this for a week or so but, thank you! I’ll be dissecting this and studying in the mean time. I’ll post back when possible.