Help making 1 to 1 relationship

[Rhino373]

Take this example data: ("|" separates columns)



RemittanceID | ReceivableID | Count
35888 | 54262 | 4
35888 | 54261 | 4
35889 | 54262 | 4
35889 | 54261 | 4

This data is showing the likeliness of remittances and receivables to match. The count field totals the likeliness.

I now need to 1 to 1 match. It really doesn't matter which ReceivableID 35888 relates itself to but if it selects 54262 then RemittanceID needs to relate itself to 54261.

My end result should either be
RemittanceID | ReceivableID | Count
35888 | 54262 | 4
35889 | 54261 | 4

OR

RemittanceID | ReceivableID | Count
35888 | 54261 | 4
35889 | 54262 | 4

Looks like I need VBA for this. Does anyone have any examples?

[Rhino373]

Just as a fun fact for those who care. I solved this by exporting the table to an Excel file and calling the following macro from a helper Excel file.

 
Sub RemoveDuplicates()
'Names the workbook "thisWB" just for easy reference later
thisWB = ActiveWorkbook.Name
Sheets(1).Name = "Sheet1"
'If the sheet called "tempsheet" exists then Delete it
Application.DisplayAlerts = False
On Error Resume Next
Sheets("tempsheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Adds a new sheet called "tempsheet"
Sheets.Add
ActiveSheet.Name = "tempsheet"
'Selects the second sheet with all the data on it
Sheets(2).Select
 
'Turns off any filters if any are turned on
If ActiveSheet.AutoFilterMode Then
    Cells.Select
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
End If
'Copies the Company Code column
Columns("A:A").Select
Selection.Copy
' Selects the "tempsheet" and pastes what was copied from the data sheet to it.
Sheets("tempsheet").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
 
If (Cells(1, 1) = "") Then
    lastrow = Cells(1, 1).End(xlDown).Row
        If lastrow <> Rows.Count Then
            Range("A1:A" & lastrow - 1).Select
            Selection.Delete Shift:=xlUp
        End If
End If
 
Columns("A:A").Select
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("B1"), Unique:=True
 
Columns("A:A").Delete
 
Cells.Select
Selection.Sort _
    Key1:=Range("A2"), Order1:=xlDescending, _
    Header:=xlYes, OrderCustom:=1, _
    MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
 
zMaxLoop = Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To zMaxLoop
    Sheets(2).Activate
    Range("A1").Select
    MaxRows = Range("A65536").End(xlUp).Row
    Sheets("tempsheet").Select
    Range("B" & x).Select
    zMaxColumn = Cells(x, Columns.Count).End(xlToLeft).Column
    ActiveCell.FormulaR1C1 = "=MATCH(R[0]C[-1],Sheet1!R1C1:R" & MaxRows & "C" & zMaxColumn & ",2)"
    Sheets(2).Range("B" & Range("B" & x).Value).Offset(0, 0).Copy Destination:=Sheets(1).Range("C" & x)
    Sheets(2).Range("C" & Range("B" & x).Value).Offset(0, 0).Copy Destination:=Sheets(1).Range("D" & x)
    MatchReceivable = Sheets(2).Range("B" & Range("B" & x).Value).Value
 
    Sheets(2).Activate
    Range("B1").Select
    For y = 1 To MaxRows
        If MatchReceivable = Range("B1").Offset(y, 0).Value Then
            Rows(y + 1).Select
            Selection.Delete Shift:=x1Up
        End If
    Next
Next
Sheets(1).Activate
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Range("B1").Select
ActiveCell.FormulaR1C1 = "ReceivableID"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Count"
Range("A1").Select
Sheets(2).Activate
Cells.Select
Selection.ClearContents
Sheets(1).Activate
Selection.CurrentRegion.Copy Destination:=Sheets(2).Range("A1")
Application.DisplayAlerts = False
On Error Resume Next
Sheets("tempsheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub

I then have Access close the helper file and import the now changed exported file appending to the existing table. (After I had deleted the duplicates from the table to start with)

[Rhino373]

Though I'm talking to myself, that didn't quite work. I needed to resume on errors when all matches for a RemittanceID were deleted. I then got rid of the lines where there were then no Receivables for that Remittance. Here is the new code.

 
Sub RemoveDuplicates()
'Names the workbook "thisWB" just for easy reference later
thisWB = ActiveWorkbook.Name
Sheets(1).Name = "Sheet1"
'If the sheet called "tempsheet" exists then Delete it
Application.DisplayAlerts = False
On Error Resume Next
Sheets("tempsheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Adds a new sheet called "tempsheet"
Sheets.Add
ActiveSheet.Name = "tempsheet"
'Selects the second sheet with all the data on it
Sheets(2).Select
 
'Turns off any filters if any are turned on
If ActiveSheet.AutoFilterMode Then
Cells.Select
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End If
'Copies the Company Code column
Columns("A:A").Select
Selection.Copy
' Selects the "tempsheet" and pastes what was copied from the data sheet to it.
Sheets("tempsheet").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
 
If (Cells(1, 1) = "") Then
lastrow = Cells(1, 1).End(xlDown).Row
If lastrow <> Rows.Count Then
Range("A1:A" & lastrow - 1).Select
Selection.Delete Shift:=xlUp
End If
End If
 
Columns("A:A").Select
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("B1"), Unique:=True
 
Columns("A:A").Delete
 
Cells.Select
Selection.Sort _
Key1:=Range("A2"), Order1:=xlDescending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
 
zMaxLoop = Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To zMaxLoop
Sheets(2).Activate
Range("A1").Select
MaxRows = Range("A65536").End(xlUp).Row
Sheets("tempsheet").Select
Range("B" & x).Select
zMaxColumn = Cells(x, Columns.Count).End(xlToLeft).Column
On Error Resume Next
ActiveCell.FormulaR1C1 = "=MATCH(R[0]C[-1],Sheet1!R1C1:R" & MaxRows & "C" & zMaxColumn & ",FALSE)"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Sheets(2).Range("B" & Range("B" & x).Value).Offset(0, 0).Copy Destination:=Sheets(1).Range("C" & x)
Sheets(2).Range("C" & Range("B" & x).Value).Offset(0, 0).Copy Destination:=Sheets(1).Range("D" & x)
MatchReceivable = Sheets(2).Range("B" & Range("B" & x).Value).Value
 
Sheets(2).Activate
Range("B1").Select
For y = MaxRows To 1 Step -1
If MatchReceivable = Range("B1").Offset(y, 0).Value Then
Rows(y + 1).Select
Selection.Delete Shift:=x1Up
End If
Next
Next
Sheets(1).Activate
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Range("B1").Select
ActiveCell.FormulaR1C1 = "ReceivableID"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Count"
Range("A1").Select
Sheets(2).Activate
Cells.Select
Selection.ClearContents
Sheets(1).Activate
Selection.CurrentRegion.Copy Destination:=Sheets(2).Range("A1")
Application.DisplayAlerts = False
On Error Resume Next
Sheets("tempsheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
For y = zMaxLoop To 1 Step -1
If Range("B" & y).Value = Empty Then
Rows(y).Select
Selection.Delete Shift:=x1Up
End If
Next
 
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub