VBA to select 2 numbers whose sum equals a third

[grizle]

I have two lists of numbers: long lists of about 1000 each in cols Aand B. If I enter a new number into cell D1 and run vba code I should like to output in cells E1 and F1 an entry from each of Cols A and B whose sum equals the new number. If there is more than one possible solution then other possibilities should be listed in Cells E2 & F2 etc below.

 

[mikerickson]

If columns A and B are unsorted (and you don't want them to be), this will do it, but not quickly.

Sub test()
    Dim aVals As Variant, aCount As Long
    Dim bVals As Variant, bCount As Long
    Dim targetVal As Double, rngResult As Range
    Dim arrResult() As Double, Pointer As Long
    Dim i As Long, j As Long
    
    With Sheet1.Range("A:A")
        With Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
            aVals = .Value
            aCount = .Cells.Count
        End With
    End With
    With Sheet1.Range("B:B")
        With Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
            bVals = .Value
            bCount = .Cells.Count
        End With
    End With
    targetVal = Range("C1").Value
    Set rngResult = Range("E1")
    ReDim arrResult(1 To aCount * bCount, 1 To 2)
    
    For i = 1 To aCount
        For j = 1 To bCount
            If aVals(i, 1) + bVals(j, 1) = targetVal Then
                Pointer = Pointer + 1
                arrResult(Pointer, 1) = aVals(i, 1)
                arrResult(Pointer, 2) = bVals(j, 1)
            End If
        Next j
    Next i
    
    With rngResult
        .Resize(1, 2).EntireColumn.ClearContents
        .Resize(Pointer, 2) = arrResult
        
    End With
End Sub

If its OK for A:B to be sorted, then this

Sub test2()
    Dim aVals As Variant, aCount As Long
    Dim bVals As Variant, bCount As Long
    Dim targetVal As Double, rngResult As Range
    Dim arrResult() As Double, Pointer As Long
    Dim i As Long, j As Long
    
    With Sheet1.Range("A:A")
        With Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
            .Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlNo
            aVals = .Value
            aCount = .Cells.Count
        End With
    End With
    With Sheet1.Range("B:B")
        With Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
            .Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlNo
            bVals = .Value
            bCount = .Cells.Count
        End With
    End With
    targetVal = Range("C1").Value
    Set rngResult = Range("E1")
    ReDim arrResult(1 To aCount * bCount, 1 To 2)
    
    For i = 1 To aCount
        For j = 1 To bCount
            If aVals(i, 1) + bVals(j, 1) = targetVal Then
                Pointer = Pointer + 1
                arrResult(Pointer, 1) = aVals(i, 1)
                arrResult(Pointer, 2) = bVals(j, 1)
            ElseIf targetVal < aVals(i, 1) + bVals(j, 1) Then
                Exit For
            End If
        Next j
    Next i
    
    With rngResult
        .Resize(1, 2).EntireColumn.ClearContents
        .Resize(Pointer, 2) = arrResult
        
    End With
End Sub

If it is already sorted, then the first half of test plus the second half of test2.

 

[steve the fish]

This seems to work:

With Sheets("Sheet1")
    myVal = .Range("D1").Value
    lr = .Range("A" & .Rows.Count).End(xlUp).Row
    arr = .Range("A1:A" & lr)
    arr2 = .Range("B1:B" & lr)
    a = 1
    .Range("E1:F" & lr).ClearContents
    For i = LBound(arr, 1) To UBound(arr, 1)
        If Not IsError(Application.Match(myVal - arr(i, 1), arr2, 0)) Then
            For j = 0 To Application.CountIf(.Range("B1:B" & lr), myVal - arr(i, 1)) - 1
                .Range("E" & a + j) = arr(i, 1)
                .Range("F" & a + j) = myVal - arr(i, 1)
            Next
            a = a + j
        End If
    Next
End With

 

[grizle]

Thanks, I'll test those. No problem having it sorted - order isnot critical. Ill be back in an hour or two - other work to do first (unfortunately)!

 

[grizle]

Thanks Mike, Unfortunately both these codes return errors. A straight macro run just gives an undefined '400' error and stepping through gives a 1004 error on the final line of code. You did refer to cells C1 and E1 in the code which are both empty; when i entered the target value into E1 intead of D1 it did (apparently) step through the FOR loops correctly but still returned the same error on the last line.

 

[grizle]

Hi Steve. Promising! With my test dataset your code returned 4 valid combinations but not the one I spiked the data with! I dont know why yet, I'll do more testing tomorrow.

 

[grizle]

Found it Steve: the two columns of data in A and B are different lengths but your code only applies the length of column A to both.

 

[steve the fish]

You could alter mine like this:

With Sheets("Sheet1")
    myVal = .Range("D1").Value
    lr = .Range("A" & .Rows.Count).End(xlUp).Row
    lr2 = .Range("B" & .Rows.Count).End(xlUp).Row
    arr = .Range("A1:A" & lr)
    arr2 = .Range("B1:B" & lr2)
    a = 1
    .Range("E1:F" & Application.Max(lr,lr2)).ClearContents
    For i = LBound(arr, 1) To UBound(arr, 1)
        If Not IsError(Application.Match(myVal - arr(i, 1), arr2, 0)) Then
            For j = 0 To Application.CountIf(.Range("B1:B" & lr2), myVal - arr(i, 1)) - 1
                .Range("E" & a + j) = arr(i, 1)
                .Range("F" & a + j) = myVal - arr(i, 1)
            Next
            a = a + j
        End If
    Next
End With

 

[grizle]

Thanks Steve. That did the job exactly as i need.