This code works in my sample file. I assume that you want to check if the item in column F of the “PTP Dash” sheet is a duplicate. Only the first occurrence of an item in col F is returned to the destination sheet. However the code is a bit slow but should be ok if run on a weekly basis.

Sub xxx()


Dim wsSource As Worksheet
Dim lastRow As Long
Dim i As Long, j As Long, k As Long, l As Long, m As Long

' Set the source worksheet and destination worksheet
Set wsSource = Worksheets("PTP Dash")

' Find the last row in column A of the source sheet
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row

j = 2
k = 2
l = 2

For i = 2 To lastRow

m = Application.WorksheetFunction.CountIfs(wsSource.Range("F2:F" & 
i), Cells(i, 6).Value)
If m = 1 Then

Select Case wsSource.Cells(i, "A").Value

Case Is = 1
wsSource.Range("D" & i).Copy Worksheets("Div 1").Range("A" & j)
wsSource.Range("F" & i).Copy Worksheets("Div 1").Range("B" & j)
j = j + 1
Case Is = 2
wsSource.Range("D" & i).Copy Worksheets("Div 2").Range("A" & k)
wsSource.Range("F" & i).Copy Worksheets("Div 2").Range("B" & k)
k = k + 1
Case Is = 3
wsSource.Range("D" & i).Copy Worksheets("Div 3").Range("A" & l)
wsSource.Range("F" & i).Copy Worksheets("Div 3").Range("B" & l)
l = l + 1
End Select

Else
End If

Next i

End Sub

The below code utilizes arrays, and does not include a filter. The heavy lifting is done in allocated memory rather than interacting with the sheet for additional filtering, etc.

There are several checks within, particularly within the function for verifying if you have a duplicate/match for both terms.

Sub test()
    With Sheets("PTP Dash")
        Dim arr1Max As Long, arr2max As Long, arr3max As Long
        Dim arrDiv1 As Variant:  ReDim arrDiv1(1, 0)
        Dim arrDiv2 As Variant:  ReDim arrDiv2(1, 0)
        Dim arrDiv3 As Variant:  ReDim arrDiv3(1, 0)
        Dim ptpLastRow As Long:  ptpLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim i As Long:  For i = 2 To ptpLastRow
            Dim divNum As Long:  divNum = .Cells(i, 1).Value
            Dim displayCode As String:  displayCode = .Cells(i, 4).Value
            Dim articleDesc As String:  articleDesc = .Cells(i, 6).Value
            If checkDestRange(divNum, displayCode, articleDesc) = 0 Then
                Select Case divNum
                    Case 1
                        ReDim Preserve arrDiv1(1, 0 To arr1Max + 1)
                        arrDiv1(0, arr1Max + 1) = displayCode
                        arrDiv1(1, arr1Max + 1) = articleDesc
                        arr1Max = arr1Max + 1
                    Case 2
                        ReDim Preserve arrDiv2(1, 0 To arr2max + 1)
                        arrDiv2(0, arr2max + 1) = displayCode
                        arrDiv2(1, arr2max + 1) = articleDesc
                        arr2max = arr2max + 1
                    Case 3
                        ReDim Preserve arrDiv3(1, 0 To arr3max + 1)
                        arrDiv3(0, arr3max + 1) = displayCode
                        arrDiv3(1, arr3max + 1) = articleDesc
                        arr3max = arr3max + 1
                End Select
            End If
        Next i
    End With
    Dim destLastRow As Long
    With Sheets("Div 1")
        destLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Cells(destLastRow + 1, 1).Resize(arr1Max, 2).Value = Application.Transpose(arrDiv1)
    End With
    With Sheets("Div 2")
        destLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Cells(destLastRow + 1, 1).Resize(arr2max, 2).Value = Application.Transpose(arrDiv2)
    End With
    With Sheets("Div 3")
        destLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Cells(destLastRow + 1, 1).Resize(arr3max, 2).Value = Application.Transpose(arrDiv3)
    End With
End Sub

Function checkDestRange(divNum As Long, termA As String, termB As String)
    Dim destWS As Worksheet:  Set destWS = Sheets("Div " & divNum)
    With destWS
        Dim destLastRow As Long:  destLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        If destLastRow = 1 Then
            checkDestRange = 0
            Exit Function
        End If
        Dim destArray As Variant:  destArray = .Range(.Cells(1, 1), .Cells(destLastRow, 2)).Value
    End With
    Dim i As Long:  For i = 1 To destLastRow
        If destArray(i, 1) = termA And destArray(i, 2) = termB Then
            checkDestRange = i
            Exit For
        Else
            checkDestRange = 0
        End If
    Next i
End Function

I am not sure if understand correctly what you mean by “an item might be on the list that was entered the week before, so I also want to confirm it is not a duplicate when I copy it” and since my reputation is too low to comment I can only guess, but maybe you can give me a hint, if the following doesn’t serve your needs:

The following code does first find the lowest and highest division numbers in column A (in case you later move on to more divions or only items of division 2 are there).

Then it does loop as many times as different divisions are given, using the division values to identify the worksheets that shall be pasted to (so in case you may add more division later on, you might want to add a routine to check wether the respective div-sheet already exists or not).

Within the loop, the code does filter column “A” in the “PTP Dash” sheet for the current division and copy all visible cells from columns “D” and “F” and paste it to columns “A:B” of the respective division sheet.

After pasting all duplicates are deleted from Columns A:B of the respective division sheet (please check if this is what you want).

So the resulting code looks like this:

Sub CopyPaste_Fruits()

Dim intDivision As Integer
Dim intMin As Integer
Dim intMax As Integer
Dim lngLastRow As Long
Dim lngNextFreeRow As Long      

    Application.ScreenUpdating = False 'makes execution faster and screen doesn't flicker

    With ThisWorkbook.Sheets("PTP Dash")
        
        intMin = WorksheetFunction.Min(.Range("A:A")) 'find the lowest number of division
        intMax = WorksheetFunction.Max(.Range("A:A")) 'find the highest number of division
        
        lngLastRow = .Cells(Rows.Count, 1).End(xlUp).Row 'find the last row with data in "PTP Dash"

        For intDivision = intMin To intMax 'Loop as many times as there are different divisions
        
            .Columns(1).AutoFilter Field:=1, Criteria1:=intDivision 'filter column one for the currently selected division in the loop
                
            lngNextFreeRow = ThisWorkbook.Sheets("Div " & intDivision).Cells(Rows.Count, 1).End(xlUp).Row + 1 'find the next free row in the sheet where you want to paste to
                
            .Range("D2:D" & lngLastRow & ",F2:F" & lngLastRow).Copy 'copy the filtered data
            ThisWorkbook.Sheets("Div " & intDivision).Range("A" & lngNextFreeRow).PasteSpecial xlValues 'paste the data
            
            'depending on if I understood correctly what your case is or not, this line (deleting duplicates in the "Div"-Worksheets may need a change:
            ThisWorkbook.Sheets("Div " & intDivision).Range("A:B").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
        
        Next
        
        .Columns(1).AutoFilter 'remove the filter
                
    End With
    
    Application.ScreenUpdating = True
    MsgBox "Copy/Paste done.", vbInformation

End Sub

Please let me know if any adjustments are needed or in case any questions are left (or new ones arise).