VBA sorting problem and moving rows based on criteria

[Burrgogi]

When there is a sale at Fanatical, people will post their findings on reddit. (Fanatical is a website that sells video games). Here is a recent sample.

What I do is highlight & copy that table and paste it into Excel so I can keep track of all their sales on an on-going basis. Much of the process is very repetitive so I've put together a simple macro. It does 90% of what I need except for a couple of problems. First problem is that if there is a game that happens to be rated at 100% positive, the macro sorts everything correctly except for that 100% rated item. As you can see from the screenshot, for some odd reason, it lists that particular item at the very end. The other thing I would like to have automated is the following steps:

"If there is a match (in col. B)",

1) then go to the end of the list
2) skip 2 rows
3) Type in "Already In my Collection:"
4) move all the rows that have a match below that header. (See the 2nd half of my screenshot)

I am not a VBA expert by any means. My macro was created by simply recording some steps plus taking snippets I found on the interwebz.

Here is my code:

Sub Fanatical_Update_Tracker_Test()
'
' Fanatical_Update_Tracker_Test Macro
'
    Workbooks.Open Filename:= _
        "C:\Test\Game Collection\Fanatical Bundle Tracker Workbook  (started on Nov 6, 2020).xlsm"
    Sheets.Add After:=Sheets(Sheets.Count), Type:= _
        "C:\Users\Name\AppData\Roaming\Microsoft\Templates\Fanatical Bundle Tracker 2A.xltx"
    ActiveSheet.Name = Format(Date, "mm_dd_yyyy")
    Range("A2").Select
    ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.ColumnWidth = 8.86
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "AIC?"
    Columns("D:D").Select
    Selection.Replace What:=" Reviews ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Columns("F:F").Select
    Selection.Replace What:="Yes ", Replacement:="Yes", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="No ", Replacement:="No", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Range("E2:E34").Select
    Selection.ClearContents
    Dim cell As Range
    For Each cell In ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)
    cell = WorksheetFunction.Trim(cell)
    Next cell
    Range("B2").Select
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range( _
        "D2:D25"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    'ActiveWorkbook.Worksheets("03_03_2022").Sort.SortFields.Add Key:=Range( _
        "D2:D23"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range("A1:H25")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1], library!R2C1:R2302C1, 1, FALSE)"
    Selection.AutoFill Destination:=Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row)
Range(Selection, Selection.End(xlDown)).Select
    Range("I1").Select
End Sub

 

[BSALV]

excel preforms an alphabetic sort and acts correct, "100%" < "99%" !!
So replace that 100% by something that is later in the alphabet (=ASCII-code)
For example replace 100 by hundred ---> "hundred%" > "99%"
in your macro, you delete " reviews " in column D, add this in the next line

    Columns("D").Replace What:="100%", Replacement:="hundred%", LookAt:=xlPart

 

[BSALV]

this part replaces the last lines starting with "Range("B2").Select"

 With Range("$A$1").CurrentRegion
          Set c = .Cells(.Rows.Count + 3, 1)                    'skip 2 row under your data
          c.Value = "Already In my Collection:"

          .AutoFilter
          .Cells(1, 2).Resize(.Rows.Count - 1).FormulaR1C1 = "=--ISNUMBER(MATCH(RC[-1], library!R2C1:R2302C1, 0))"
          .AutoFilter 2, 1
          .Offset(1).Copy
          c.Offset(1).PasteSpecial xlAll
          .AutoFilter
     End With

 

[Burrgogi]

this part replaces the last lines starting with "Range("B2").Select"

 With Range("$A$1").CurrentRegion
          Set c = .Cells(.Rows.Count + 3, 1)                    'skip 2 row under your data
          c.Value = "Already In my Collection:"

          .AutoFilter
          .Cells(1, 2).Resize(.Rows.Count - 1).FormulaR1C1 = "=--ISNUMBER(MATCH(RC[-1], library!R2C1:R2302C1, 0))"
          .AutoFilter 2, 1
          .Offset(1).Copy
          c.Offset(1).PasteSpecial xlAll
          .AutoFilter
     End With

Thanks for the code BSALV. One quick adjustment to make. Instead of copying the rows that match, I'd like to move them all to the bottom. I changed it to Cut and for some reason, it broke your code.
.Offset(1).Cut

Secondly, it's selecting a blank row after the last match. (See screenshot attached). Not a big deal but I'd like to understand why it's doing that.

 

[BSALV]

no without extra line.
When you filter data and afterwards copy those filtered data without the header, you use the offset(1), so the range you're dealing with shifts 1 down, = leave the header, but take 1 extra line below.
In the macro here below, you still don't want the header, so again that offset(1) but now because of the resize(.rows.count-1), you don't take an extra row below that range.

I think you want it now like this

Sub Separate_Collection_Items()

     With Range("$A$1").CurrentRegion                           'a contigious block around A1
          Set c = .Cells(.Rows.Count + 3, 1)                    'destination = skip 2 row under your data
          c.Value = "Already In my Collection:"                 'start text
          .AutoFilter                                           'reset filter on A1 (in case of)
          .Cells(2, 2).Resize(.Rows.Count - 1).FormulaR1C1 = "=--ISNUMBER(MATCH(RC[-1], library!R2C1:R2302C1, 0))"     'check if game is already in library (1=true, 0 =false)
          .AutoFilter 2, 1                                      'filter all the "already in collection"
          If .Columns(1).SpecialCells(xlVisible).Count > 1 Then     'at least 1 already in collection
               With .Offset(1).Resize(.Rows.Count - 1)          'those filtered rows
                    .Copy                                       'copy them
                    c.Offset(1).PasteSpecial xlAll              'paste hem below the start text
                    .Delete xlUp                                'delete them in the upper part
               End With
          End If

          .AutoFilter                                           'reset filter
     End With
End Sub

 

[Burrgogi]

Thanks for your help BSALV, that works!