Getting duplicated from two sheets and outputting the difference of their associated costs

[Jessica007]

Hello,

I have an excel file with 2 spreadsheets. Each has two columns. Column A has a name and Column B is a list of costs associated with each name.
I need to write a macro which finds all duplicates in Column A of both sheets and outputs that onto a third sheet. Then I need the macro to also subtract Sheet2's cost from Sheet1 and output that as well onto the third sheet. It should get the difference for each name. Then rearrange the data alphabetically.

Example
Sheet1 Sheet2 Sheet3
Jane 1 David 5 Alice 1
Alice 2 Jane 3 David 5
Mark 4 Alice 1 Jane -2
David 10 John 4


Here is my code so far:

Sub ListDuplicates()

  Dim DSO As Object
  Dim DstWks As Worksheet
  Dim LastRow As Long
  Dim I As Integer
  Dim R As Long
  Dim ShtNames As Variant
  Dim Wks As Worksheet
    
    R = 2
    ShtNames = Array("Sheet1", "Sheet2", "Sheet3")
    
   'Last sheet is the destination sheet
    Set DstWks = Worksheets(ShtNames(2))
    DstWks.UsedRange.Offset(1, 0).ClearContents

    Set DSO = CreateObject("Scripting.Dictionary")
    DSO.CompareMode = vbTextCompare
    
     'Create list of all unique values on "Sheet1"
      For I = 0 To 0
        With Worksheets(ShtNames(I))
          Set Rng = .Cells(2, "A")
          LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
          If LastRow >= Rng.Row Then Set Rng = Rng.Resize(LastRow + Rng.Row - 1, 1)
            For Each Cell In Rng
              If Not DSO.Exists(Trim(Cell.Value)) Then
                 DSO.Add Cell.Value, Cell.Offset(0, 1).Value
              End If
            Next Cell
        End With
      Next I
      
     'Copy values common to both sheets to the destination worksheet
      Set Wks = Worksheets(ShtNames(1))
        With Wks
          Set Rng = .Cells(2, "A")
          LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
          If LastRow >= Rng.Row Then Set Rng = Rng.Resize(LastRow + Rng.Row - 1, 1)
            For Each Cell In Rng
              If DSO.Exists(Trim(Cell.Value)) Then
                 DstWks.Cells(R, "A") = Cell
                 
                 Dim x As Variant
                 Dim y As Variant
                 
                 Set S1 = Sheets(1).Range("B1:B10000")
                 Set S2 = Sheets(2).Range("B1:B10000")
                 
        
                 For Each x In S1
                    For Each y In S2
                        If x = y Then
                            DstWks.Cells(R, "B") = CInt(x.Offset(0, 1)) - CInt(y.Offset(0, 1))
                          
                        End If
                    Next y
                Next x
            
                 R = R + 1
              End If
            Next Cell
        End With
   
End Sub

Any help is appreciated!
Thanks so much!