Create a Worksheet comparison between two days

[Will41GG]

Hello All,

I am creating a sheet that will filter through data using a set criteria (cAmt = 3000000 and aged = 3 in the code) and returning the results to the REC sheet, the data input in(the CASH EAR tab) changes daily which means the filtered Data being copied into the REC Sheet changes daily.

I want to capture the data that changes i.e no longer on the REC sheet before I post the new filtered data in the Rec sheet

My idea is trying to create a temp worksheet that will hold the new filtered data and compare it to yesterdays previous data and return the results to the 'CLEARED' worksheet, is this possible? or the best solution?

before finally pasting the new filtered data

Below is the Code I am using but failing:

Dim search_for As String
        Dim cnt As Integer
      
        r = Cells(Rows.Count, "A").End(xlUp).Row
        q = Cells(Rows.Count, "A").End(xlUp).Row
      
        'Set wkb1 = ThisWorkbook
        Set ws = Worksheets("REC")
      
        Application.ScreenUpdating = False
         
  
  cAmt = Sheets("REC").Cells(3, 12)
  aged = Sheets("REC").Cells(2, 12)


  With Sheets("Cash EAR")
    With .Range("A17", .Cells(.Rows.Count, "X").End(xlUp))
      .AutoFilter 24, ">" & cAmt
      .AutoFilter 20, ">" & aged
      .EntireRow.Copy
    End With
  
 
    'Compare Data with Temp Sheet and Paste differences into Cleared tab
    '
    'Continue Rec Process
    '
    '
    '
    'Create new Rec For Day
      
    
    With Sheets("REC")
        With .Range("A9", .Cells(.Rows.Count, "A").End(xlDown))
        .PasteSpecial xlPasteValues
        Application.CutCopyMode = False

      
        Sheets("REC").Range("E9:X9").EntireRow.Hidden = True
        Sheets("REC").Range("J:J").EntireColumn.Hidden = True
        Sheets("REC").Range("F:F").EntireColumn.Hidden = True
        Sheets("REC").Range("B:B").EntireColumn.Hidden = True
        Sheets("REC").Range("S:S").EntireColumn.Hidden = True
        Sheets("REC").Range("W:W").EntireColumn.Hidden = True
        Sheets("REC").Range("V:V").EntireColumn.Hidden = True
         
    End With
    End With
  End With


  With Sheets("REC")
    With .Range("Z10", .Cells(.Rows.Count, "AA").End(xlDown))
    With .Font
            .Name = "Arial"
            .FontStyle = "Regular"
            .Size = 8
    End With
    End With
    End With
  
    With Sheets("REC").Columns("AA")
        .ColumnWidth = 60
    End With
  
    With Sheets("REC").Columns("AB")
        .ColumnWidth = 60
    End With
  
  
   
      For x = 10 To r
        If ws.Application.WorksheetFunction.CountBlank(ws.Range(ws.Cells(x, 21), ws.Cells(x, 21))) > 0 Then
            ws.Cells(x, 26) = "MC"
          
        Else
            If ws.Range(ws.Cells(x, 20), ws.Cells(x, 20)) > 300 Then
            ws.Cells(x, 26) = "AGD"
         
        Else
            If InStr(1, ws.Range(ws.Cells(x, 21), ws.Cells(x, 21)).Value, "STIF") > 0 Then
            ws.Cells(x, 26) = "PB"
          
        Else
           If InStr(1, ws.Range(ws.Cells(x, 21), ws.Cells(x, 21)).Value, "CAID") > 0 Then
            ws.Cells(x, 26) = "NIR"
      
        Else
            ws.Cells(x, 26) = "IR"
          
            End If
            End If
        End If
        End If
      
        Next x
      
    For y = 10 To q
  
        If ws.Range(ws.Cells(y, 26), ws.Cells(y, 26)) = "MC" Then
            ws.Cells(y, 27) = "Missing Commentary  - Email sent to  to update"
        Else
            If ws.Range(ws.Cells(y, 26), ws.Cells(y, 26)) = "PB" Then
            ws.Cells(y, 27) = "Persistent break week to week -  investigation assistance required to clear"
        Else
            If ws.Range(ws.Cells(y, 26), ws.Cells(y, 26)) = "NIR" Then
            ws.Cells(y, 27) = "No investigation required -  team assigned the investigation progress sufficient"
        Else
            If ws.Range(ws.Cells(y, 26), ws.Cells(y, 26)) = "AGD" Then
            ws.Cells(y, 27) = "Aged - Check the status of break. Usually due to STIF balance"
        Else
            If ws.Range(ws.Cells(y, 26), ws.Cells(y, 26)) = "IR" Then
            ws.Cells(y, 27) = "Information request to  for assistance"
                 End If
                End If
            End If
         End If
        End If
          
      
        Next y


End Sub

Above code works

Code that breaks the workbook:

'Set wsTemp = Workbooks.Add
        'wsTemp.Worksheets.Add Count:=1
        wsTemp.Sheets.Add
        wsTemp.Sheets(1).Name = "RECtemp"
      
    With Sheets("RECtemp")
        With .Range("A9", .Cells(.Rows.Count, "A").End(xlDown))
        .PasteSpecial xlPasteValues
        End With
    End With
  
  
    'Compare Fields between REC sheet (column K) and TempSheet (column K)
  
Do While ActiveCell.Value <> ""
      
        search_for = ActiveCell.Offset(10, 10).Value
      
        wsTemp.Sheets("RecTemp").Activate
      
        On Error Resume Next
  
        Range("K:K").Find(search_for).Select
  
        If Err <> 0 Then
      
        On Error GoTo 0
      
        wkb1.Sheets("REC").Activate
  
        'f = ActiveCell.Row
      
        .Select
      
        cnt = cnt + 1
      
        Selection.Copy
      
        wkb1.Sheets("Cleared").Activate
        Range("B2").Select
        ActiveCell.PasteSpecial xlPasteAll
        ActiveCell.Offset(1, 0).Select
      
    End If
    wkb1.Sheets("REC").Activate
    ActiveCell.Offset(1, 0).Select
  
    Loop
      
    With Sheets("Cash EAR")
    With .Range("A17", .Cells(.Rows.Count, "X").End(xlUp))
      .AutoFilter 24, ">" & cAmt
      .AutoFilter 20, ">=" & aged
      .EntireRow.Copy
    End With
    End With

 

[Peter_SSs]

When posting vba code, please use code tags to preserve the indentation formatting. Trying to read/debug code that is all left-aligned is very difficult.
See my signature block below for more details. I have fixed the tags in the above post for you on this occasion.