An Algorithm that matches two lists

[DDONNI]

HI Guys, i was wondering if some could help me with this one, i'm trying
to create an algorithm that will match between to lists and copy the
match data from list 2 into list 1.

Its for and order system, List 1 contains information of all orders
made, and the orders can have more than one order line, with each line
representing and item bought. List 2 comtains the Invoice data, but
this is where it gets complicated as the invoices can come in for an
entire order or for each order line or even worse a partial payment for
an order line. The other thing is the invoice list doesn't have the
order line only the order number and price, where as the first list
shows the order number, order line and price. Basically there's a 1-1,
1-many on many-1 relationship on an order line level. To make it more
complicated there's no limit on order lines per order and there's no
limit on how many invoices per order. Though one restriction is an
invoice will not come in to pay for 1 order line and part of another.
Also i need it to create a new table from list 2 of the invoice it
couldn't match.

Can anyone help me on this, i know its a bit long winded and
complicated but our company is totally backward and i don't think there
going to be a change in the process anytime soon.

 

[keepITcool]

Try to adapt following code which compares
unordered ranges (single column) and gives you 3 resulting
arrays ....


Option Explicit
Sub Demo()
Call AnalyseIT([a1:a1000], [b1:b1000], [g1:i1])
End Sub

Sub AnalyseIT(rList1 As Range, rList2 As Range, rDest As Range)
'Author: keepITcool
Dim col(3) As Collection
Dim arr(3) As Variant
Dim tmp As Collection
Dim itm As Variant
Dim n&, i&

For n = 0 To 2
Set col(n) = New Collection
Next

On Error Resume Next
'Fill tmp
Set tmp = New Collection
For Each itm In rList1.Cells
If LenB(itm) <> 0 Then tmp.Add itm.Value2, CStr(itm.Value2)
Next

For Each itm In rList2.Cells
If LenB(itm) <> 0 Then
If IsError(tmp(CStr(itm.Value2))) Then
'Right join
col(2).Add itm.Value2, CStr(itm.Value2)
Else
'Inner join
col(1).Add itm.Value2, CStr(itm.Value2)
End If
End If
Next
For Each itm In tmp
If IsError(col(1)(CStr(itm))) Then
'Left join
col(0).Add itm, CStr(itm)
End If
Next
Set tmp = Nothing
For n = 0 To 2
arr(n) = col2arr(col(n))
qSort arr(n)
Next

rDest.Cells(1, 1).Resize(col(0).Count) = arr(0)
rDest.Cells(1, 2).Resize(col(1).Count) = arr(1)
rDest.Cells(1, 3).Resize(col(2).Count) = arr(2)

End Sub

Function col2arr(col As Collection) As Variant()
Dim n&, res
With col
ReDim res(1 To .Count, 1 To 1)
For n = 1 To .Count
res(n, 1) = col(n)
Next
End With
col2arr = res
End Function

Public Sub qSort(v, Optional n& = True, Optional m& = True)
Dim i&, j&, p, t
If n = True Then n = LBound(v, 1): If m = True Then m = UBound(v, 1)
i = n: j = m: p = v((n + m) \ 2, 1)
While (i <= j)
While (v(i, 1) < p And i < m): i = i + 1: Wend
While (v(j, 1) > p And j > n): j = j - 1: Wend
If (i <= j) Then
t = v(i, 1): v(i, 1) = v(j, 1): v(j, 1) = t
i = i + 1: j = j - 1
End If
Wend
If (n < j) Then qSort v, n, j
If (i < m) Then qSort v, i, m
End Sub



keepITcool

< email : keepitcool chello nl (with @ and .) >
< homepage: http://members.chello.nl/keepitcool >