compare 3 arrays. If uniqe in dimmesion (2,3,4) then check and copy to Tab1 or Tab3

[mokie]

Hello, dear friends please show me where I lost in my code becouse I don't have good result in it.
I thing I'm lost in iteration in 3 loops for / next.
I was trying compare 3 arrays and after matching copy to worksheet in
TABLE1 (unique)
TABLE3 (duplicates) - diffrent position of column
TABLE2 (source table with new record)

arr1 (TABLE1) - destination new uniqe record
arr2 (TABLE2) - source record
arr3 (TABLE3) - dupicate record in arr1=arr2. But check if exist in arr3. If exist do not copy again to table 3.
thanks in advanced.



Sub compareArrays_copyRecord()
Dim arr
Dim arr2
Dim j As Long
Dim k As Long
Dim o As Long
Dim BlankRow As Long
BlankRow = Sheets("MAIN").Cells(Rows.Count, 1).End(xlUp).Row
BlankRowG = Sheets("MAIN").Cells(Rows.Count, 7).End(xlUp).Row

'' Array1 of destination of uniqe records
arr = Range("A5").CurrentRegion.Value
'' Array2 - source of new record. Many of record is duplicates. Must check if exist in table1 if not then paste to Table3. If exist on Table3 do not copy at all.
arr2 = Range("M5").CurrentRegion.Value
'' Array from G19. Check is the record is exist from arr2(Source) - table2 . Do not copy again to table1 or table3.
arr3 = Range("G5").CurrentRegion.Value


For o = LBound(arr3) To UBound(arr3)
For k = LBound(arr2) To UBound(arr2)
For j = LBound(arr) To UBound(arr)

'' (Table1) header 2 , 3, 4 <> or = (table2) header 2 , 3 , 4
If arr(j, 2) & arr(j, 3) & arr(j, 4) <> arr2(k, 2) & arr2(k, 3) & arr2(k, 4) Then

'in columnG(arr3) paste record exist in colA(arr1) and colM(arr2)

If arr2(k, 2) & arr2(k, 4) & arr2(k, 3) <> arr3(o, 1) & arr3(o, 2) & arr3(o, 3) Then
Cells(BlankRowG + 1, 7).Select
Selection = arr3(o, 1)
Selection.Offset(0, 1) = arr3(o, 2)
Selection.Offset(0, 2) = arr3(o, 3)
Selection.Offset(0, 3) = arr3(o, 4)


If arr(j, 2) & arr(j, 3) & arr(j, 4) = arr2(k, 2) & arr2(k, 3) & arr2(k, 4) Then

Cells(BlankRow + 1, 1).Select
Selection = arr2(k, 1)
Selection.Offset(0, 1) = arr2(k, 2)
Selection.Offset(0, 2) = arr2(k, 3)
Selection.Offset(0, 3) = arr2(k, 4)
Selection.Offset(0, 4) = arr2(k, 5)

End If

End If
End If
Next j

Next k

Next o
End Sub

[mokie]

Hello, 1 year ago Mr. p45cal (http://www.vbaexpress.com/forum/member.php?3494-p45cal)help me a lot in very similar case. Works so good and fast as lightning:)
I still don't get it ;/ how to modificate it and on new issue I try to start on basic to understand arrays again.





Maybe somebody will check those code to modificate for new issue what I need it.

Old Thread
http://www.vbaexpress.com/forum/showthread.php?58573-copy-rows-if-number-doesn-t-exist-in-all-worksheet/page2

Check for new record
if exist unique number in worksheet name DataBase
if not then
looking for exist all sheets in ActiveWorkbook and looking for strings from column (3,4,7)
and paste only new record.


Right now I'd don't need looking all of worksheet in workbook but I need to compare only 3 places:)
Thanks in advanced


Sub SearchReq6()
Dim tb, OutSht, IsNowhereElse As Boolean, sht
Dim i As Long, j As Long, k As Long, kol
Dim req1, req2, req3DateLowL, req4DateUppL

kol = Array(1, 2, 3, 4, 7, 5, 12, 9, 11) 'newer 'maps out the arrangement of columns from the DataBase sheet to the OutSheet.
DBaseUniqNumberColm = 2 'the column holding the unique numbers on the DataBase sheet (and others except for OutSheet)
'prepare some arrays of combinations of columns of other sheets to be used for searching for duplicates later:
OtherSheetsColms = Array(3, 4, 7) 'the other sheets (includes DataBase sheet) columns to concatenate to make unique combo to check against when unique number is blank.

'Only the above 3 variables (kol, DBaseUniqNumberColm and OtherSheetsColms) need to be set manually; the rest are worked out (I think!)
'Note we could also put the 65000 in a variable; it might save a little time to change it to x if you know you will NEVER have more than x rows on any sheet, ever. The actual maximum is 65536

'OutSheetColms = Array(3, 4, 5) 'the OutSheet columns to concatenate to make unique combo when unique number is blank.
OutSheetColms = Array(Application.Match(OtherSheetsColms(0), kol, 0), Application.Match(OtherSheetsColms(1), kol, 0), Application.Match(OtherSheetsColms(2), kol, 0)) 'automation of commented-out line above.
OutShtUniqNumberColm = Application.Match(DBaseUniqNumberColm, kol, 0) 'works out which column in the OutSheet has the Unique Numbers.
ReDim ff(1 To Sheets.Count)
j = 0
For Each sht In ThisWorkbook.Sheets 'exclude outsht and database
If sht.Name <> "DataBase" Then '"OutSheet" Then 'And sht.Name <> "DataBase" Then
j = j + 1
If sht.Name = "OutSht" Then 'because there was a different set of columns to be used in the OutSheet.
a = sht.Cells(5, OutSheetColms(0)).Resize(65000).Value
b = sht.Cells(5, OutSheetColms(1)).Resize(65000).Value
c = sht.Cells(5, OutSheetColms(2)).Resize(65000).Value
Else
a = sht.Cells(2, OtherSheetsColms(0)).Resize(65000).Value 'do the other sheets' data start at row 5 too? If so change the 2 to a 5 (same applies to next 2 lines).
b = sht.Cells(2, OtherSheetsColms(1)).Resize(65000).Value
c = sht.Cells(2, OtherSheetsColms(2)).Resize(65000).Value
End If
ReDim d(1 To UBound(a))
For k = 1 To UBound(d)
If Not (IsEmpty(a(k, 1)) And IsEmpty(b(k, 1)) And IsEmpty(c(k, 1))) Then
'If IsEmpty(c(k, 1)) Then cc = Empty Else cc = CStr(CLng(c(k, 1))) 'may no longer need the clng. 'Remnant from when 3rd column was a date.
d(k) = a(k, 1) & "¬" & b(k, 1) & "¬" & c(k, 1)
End If
Next k
ff(j) = d
End If
Next sht
ReDim Preserve ff(1 To j)
'end of creating lookup (Match) arrays.
Set OutSht = ThisWorkbook.Sheets("OutSheet")
With ThisWorkbook.Sheets("DataBase")
req1 = .[A2]
req2 = .[B2]
req3DateLowL = .[E2]
req4DateUppL = .[F2]
tb = .Range("A5:L" & .Cells(.Rows.Count, 2).End(xlUp).Row) 'this uses column 2 to decide where the bottom of the table is; this may not be the best since you've told me that some unique numbers can be blamk - so change this.
ReDim tempArray(1 To UBound(tb, 2))
j = 0
For i = 1 To UBound(tb)
If (tb(i, 4) = req1) And (tb(i, 11) >= req3DateLowL) And (tb(i, 11) <= req4DateUppL) Or ((tb(i, 4) = req2 And (tb(i, 11) >= req3DateLowL And tb(i, 11)) <= req4DateUppL)) Then
'check for presence elsewhere: search the other sheets:
IsNowhereElse = True
If IsEmpty(tb(i, DBaseUniqNumberColm)) Then 'if unique number is blank,search for the columns C,D,E combo in other sheets:
'Stop
'pp = tb(i, 3) & tb(i, 4) & IIf(IsEmpty(tb(i, 5)), Empty, CLng(tb(i, 5))) 'column 5 treated diferently since it contains dates.
' pp = tb(i, 3) & "¬" & tb(i, 4) & "¬" & tb(i, 7)
pp = tb(i, OtherSheetsColms(0)) & "¬" & tb(i, OtherSheetsColms(1)) & "¬" & tb(i, OtherSheetsColms(2)) 'automation of above, commented-out, line.
For k = LBound(ff) To UBound(ff)
If Not IsError(Application.Match(pp, ff(k), 0)) Then 'this is the line that has the limit of 65k plus members in ff(k).
IsNowhereElse = False
Exit For
End If
Next k
Else 'if unique number is not blank: this bit searches for unique number match elsewhere:
For Each sht In ThisWorkbook.Sheets
If sht.Name <> "DataBase" Then
If sht.Name = "OutSht" Then myColm = OutShtUniqNumberColm Else myColm = DBaseUniqNumberColm
If Not IsError(Application.Match(tb(i, DBaseUniqNumberColm), sht.Columns(myColm), 0)) Then
IsNowhereElse = False
Exit For
End If
End If
Next sht
End If
'end search the other sheets.
If IsNowhereElse Then
'check all values aren't empty first (no sense copying a blank row):
AllEmpty = True
For k = LBound(kol) To UBound(kol)
If Not IsEmpty(tb(i, kol(k))) Then
AllEmpty = False
Exit For
End If
Next
'end of check all values aren't empty first
If Not AllEmpty Then
j = j + 1
If j = i Then
For k = LBound(tempArray) To UBound(tempArray) 'copy table row:
tempArray(k) = tb(i, k)
Next
For k = LBound(kol) To UBound(kol) 'now get data from copy:
tb(j, k + 1) = tempArray(kol(k))
Next
Else
For k = LBound(kol) To UBound(kol)
tb(j, k + 1) = tb(i, kol(k))
Next
End If
End If
End If
End If
Next i
If j > 0 Then OutSht.Cells(OutSht.Rows.Count, "A").End(xlUp).Offset(1).Resize(j, UBound(kol) + 1) = tb
End With
End Sub