VBA - Compare Two Sheets and Pull Results on New Sheet

[Starbel]

Hi all,



My skill in translating logic into a formula and especially VBA is very limited. Hopefully the below makes sense.



Basically I was hoping for a VBA code that pulls through results on to a new sheet by using the reference column A (Order Ref) in Sheet 2 and comparing columns of the corresponding Column A in Sheet 1. I was then hoping to pull through results on to sheet 3 based on the following unrelated columns in Sheet 2 –

1. Column I = Y

and is

1. Column G = more than 6 months difference in date vs sheet 1 (sheet 1 will have the later/future dates)

OR

1. Column B = does not match column B in sheet 1

Hopefully the below helps illustrate this –

Sheet 1​
A​	B​	C​	D​	E​	F​	G​	H​	I​	J​
Order Ref​	Customer​	Type​	PO​	BA​	VALUE​	Order Start​	Discount​	Duty​	Duty Startdate​
123​	Harry​	Apple​	1​	New Request​	$3,443.00​	01/06/2022​	Y​	N​	01/07/2022​
14300​	John​	Pear​	3​	New Request​	$655.00​	01/04/2022​	Y​	N​	01/04/2022​
7800​	Kevin​	Orange​	5​	New Request​	$656.00​	01/06/2022​	Y​	N​	01/04/2023​
7800​	Peter​	Mango​	7​	New Request​	$453.00​	01/04/2023​	Y​	Y​	01/04/2023​
73900​	James​	Strawberry​	1​	New Request​	$656.00​	01/02/2023​	Y​	Y​	01/07/2023​
900​	Jack​	Blackberry​	2​	New Request​	$567.00​	01/03/2023​	​	N​	01/03/2023​
18800​	Levi​	Pineapple​	4​	New Request​	$3,445.00​	03/06/2023​	Y​	N​	03/06/2023​
188002​	Leon​	Apple​	6​	New Request​	$676.00​	01/01/2014​	Y​	Y​	01/01/2014​
Sheet 2​
A​	B​	C​	D​	E​	F​	G​	H​	I​	J​
Order Ref​	Customer​	Type​	PO​	BA​	VALUE​	Order Start​	Discount​	Duty​	Duty Startdate​
123​	Harry​	Apple​	1​	New Request​	$3,443.00​	01/06/2022​	Y​	Y​	01/06/2022​
14300​	John​	Pear​	3​	New Request​	$655.00​	01/04/2022​	Y​	Y​	01/04/2022​
7800​	Kevin​	Orange​	5​	New Request​	$656.00​	01/06/2022​	Y​	Y​	01/06/2022​
7800​	Peter​	Mango​	7​	New Request​	$453.00​	01/04/2023​	Y​	Y​	01/04/2023​
73900​	Philip​	Strawberry​	1​	New Request​	$656.00​	01/02/2023​	Y​	Y​	01/06/2023​
900​	Jack​	BlackBerry​	2​	New Request​	$567.00​	01/03/2023​	​	N​	01/03/2023​
18800​	Oscar​	Pineapple​	4​	New Request​	$3,445.00​	03/06/2023​	Y​	Y​	01/04/2021​
188002​	Leon​	Apple​	6​	New Request​	$676.00​	01/01/2014​	Y​	Y​	01/01/2014​
Sheet 3 Results​
A​	B​	C​	D​	E​	F​	G​	H​	I​	J​
Order Ref​	Customer​	Type​	PO​	BA​	VALUE​	Order Start​	Discount​	Duty​	Duty Startdate​
7800​	Kevin​	Orange​	5​	New Request​	$656.00​	01/06/2022​	Y​	N​	01/04/2023​
73900​	James​	Strawberry​	1​	New Request​	$656.00​	01/02/2023​	Y​	Y​	01/07/2023​
18800​	Levi​	Pineapple​	4​	New Request​	$3,445.00​	03/06/2023​	Y​	N​	03/06/2023​
188002​	Leon​	Apple​	6​	New Request​	$676.00​	01/01/2014​	Y​	Y​	01/01/2014​

Thank you so much!

 

[Starbel]

Assuming there are no repeating Types within the same Order on Sheet2:

Dim tempRange As Variant
Sub tets()
  Dim sheet1Range As Variant, sheet2Range As Variant, tempArr As Variant
  Dim sheet2Dic As Object, i As Long
  Set sheet2Dic = CreateObject("Scripting.Dictionary")
 
  sheet2Range = Worksheets("Sheet2").UsedRange
  For i = 2 To UBound(sheet2Range, 1)
    If Not sheet2Dic.Exists(sheet2Range(i, 1) & sheet2Range(i, 3)) Then
      sheet2Dic.Add sheet2Range(i, 1) & sheet2Range(i, 3), sheet2Range(i, 2) & "|" & sheet2Range(i, 7) & "|" & sheet2Range(i, 9)
    End If
  Next
 
  With Application
  sheet1Range = Worksheets("Sheet1").UsedRange
  ReDim tempRange(1 To UBound(sheet1Range, 2), 1 To 1)
  For i = 2 To UBound(sheet1Range, 1)
    If sheet2Dic.Exists(sheet1Range(i, 1) & sheet1Range(i, 3)) Then
      tempArr = Split(sheet2Dic(sheet1Range(i, 1) & sheet1Range(i, 3)), "|")
      If sheet1Range(i, 9) = tempArr(2) Then
[COLOR=rgb(0, 0, 0)][U][I][B][SIZE=4]        If sheet1Range(i, 9) > DateAdd("m", 6, tempArr(1)) Then[/SIZE][/B][/I][/U][/COLOR]
          tempArr = .Index(sheet1Range, i, 0)
          Call writeTotempRange(tempArr)
        End If
      Else
        If sheet1Range(i, 2) <> tempArr(0) Then
          tempArr = .Index(sheet1Range, i, 0)
          Call writeTotempRange(tempArr)
        End If
      End If
    End If
  Next
 
  ReDim Preserve tempRange(1 To UBound(tempRange, 1), 1 To UBound(tempRange, 2) - 1)
  Worksheets("Sheet3").Range("A1").Resize(1, UBound(sheet1Range, 2)).Value = .Index(sheet1Range, 1, 0)
  Worksheets("Sheet3").Range("A2").Resize(UBound(tempRange, 2), UBound(tempRange, 1)).Value = .Transpose(tempRange)
  End With
End Sub
Public Sub writeTotempRange(ParamArray tempArr() As Variant)
  Dim i As Long
  For i = 1 To UBound(tempRange, 1)
    tempRange(i, UBound(tempRange, 2)) = tempArr(0)(i)
  Next
  ReDim Preserve tempRange(1 To UBound(tempRange, 1), 1 To UBound(tempRange, 2) + 1)
End Sub

Hi there - great thanks!

Seems to be a problem with the highlighted part? Cant figure it out

Thanks again!

 

[Legacy 143009]

That may be caused of your dates are not formatted correctly. They are not actual dates. They are strings. Maybe...
Please try my sample file in post #10 and see.

 

[Legacy 143009]

1. Column I = Y

and is

1. Column G = more than 6 months difference in date vs sheet 1 (sheet 1 will have the later/future dates)

Hi Starbel,

In your first post you mentioned "If they are both Y and more than 6 months difference"
But now you are saying if they are "N" and "Y".
It is confusing for me. Can you try this:

Sub test()
  Dim sheet1Range As Variant, tempRange As Variant, sheet2Range As Variant, tempArr As Variant
  Dim sheet2Dic As Object, i As Long, j As Long
  Set sheet2Dic = CreateObject("Scripting.Dictionary")
 
  sheet2Range = Worksheets("Sheet2").UsedRange
  For i = 2 To UBound(sheet2Range, 1)
    If Not sheet2Dic.Exists(sheet2Range(i, 1) & sheet2Range(i, 3)) Then
      sheet2Dic.Add sheet2Range(i, 1) & sheet2Range(i, 3), sheet2Range(i, 2) & "|" & sheet2Range(i, 7) & "|" & sheet2Range(i, 9)
    End If
  Next
 
  With Application
  sheet1Range = Worksheets("Sheet1").UsedRange
  ReDim tempRange(1 To UBound(sheet1Range, 2), 1 To 1)
  For i = 2 To UBound(sheet1Range, 1)
    If sheet2Dic.Exists(sheet1Range(i, 1) & sheet1Range(i, 3)) Then
      tempArr = Split(sheet2Dic(sheet1Range(i, 1) & sheet1Range(i, 3)), "|")
      If (sheet1Range(i, 9) <> tempArr(2) And sheet1Range(i, 9) > DateAdd("m", 6, tempArr(1))) Or (sheet1Range(i, 9) = tempArr(2) And sheet1Range(i, 2) <> tempArr(0)) Then
        tempArr = .Index(sheet1Range, i, 0)
        For j = 1 To UBound(tempRange, 1)
          tempRange(j, UBound(tempRange, 2)) = tempArr(j)
        Next
      ReDim Preserve tempRange(1 To UBound(tempRange, 1), 1 To UBound(tempRange, 2) + 1)
      End If
    End If
  Next
 
  ReDim Preserve tempRange(1 To UBound(tempRange, 1), 1 To UBound(tempRange, 2) - 1)
  Worksheets("Sheet3").Range("A1").Resize(1, UBound(sheet1Range, 2)).Value = .Index(sheet1Range, 1, 0)
  Worksheets("Sheet3").Range("A2").Resize(UBound(tempRange, 2), UBound(tempRange, 1)).Value = .Transpose(tempRange)
  End With
End Sub

 

[Legacy 143009]

For correct date format add this line after End With

Worksheets("Sheet3").Range("G2").Resize(UBound(tempRange,2).NumberFormat = "dd/mm/yyyy"

 

[Starbel]

For correct date format add this line after End With

Worksheets("Sheet3").Range("G2").Resize(UBound(tempRange,2).NumberFormat = "dd/mm/yyyy"

Cant figure it out but seems like I keep getting this message?

 

[Legacy 143009]

Missing parantheses

Worksheets("Sheet3").Range("G2").Resize(UBound(tempRange,2)).NumberFormat = "dd/mm/yyyy"

 

[Legacy 143009]

So, in order to summarize what the code does is,
Finds the matching order number and product type on both sheets. Compares the following conditiond in both records:
If column I are different and there is 6 months difference (Sheet1 has further date)
OR
If column I are equal and column B is different,
Then writes that Sheet1 record to Sheet3.

Sub test()
  Dim sheet1Range As Variant, tempRange As Variant, sheet2Range As Variant, tempArr As Variant
  Dim sheet2Dic As Object, i As Long, j As Long
  Set sheet2Dic = CreateObject("Scripting.Dictionary")
 
  sheet2Range = Worksheets("Sheet2").UsedRange
  For i = 2 To UBound(sheet2Range, 1)
    If Not sheet2Dic.Exists(sheet2Range(i, 1) & sheet2Range(i, 3)) Then
      sheet2Dic.Add sheet2Range(i, 1) & sheet2Range(i, 3), sheet2Range(i, 2) & "|" & sheet2Range(i, 7) & "|" & sheet2Range(i, 9)
    End If
  Next
 
  With Application
  sheet1Range = Worksheets("Sheet1").UsedRange
  ReDim tempRange(1 To UBound(sheet1Range, 2), 1 To 1)
  For i = 2 To UBound(sheet1Range, 1)
    If sheet2Dic.Exists(sheet1Range(i, 1) & sheet1Range(i, 3)) Then
      tempArr = Split(sheet2Dic(sheet1Range(i, 1) & sheet1Range(i, 3)), "|")
      If (sheet1Range(i, 9) <> tempArr(2) And sheet1Range(i, 9) > DateAdd("m", 6, tempArr(1))) Or (sheet1Range(i, 9) = tempArr(2) And sheet1Range(i, 2) <> tempArr(0)) Then
        tempArr = .Index(sheet1Range, i, 0)
        For j = 1 To UBound(tempRange, 1)
          tempRange(j, UBound(tempRange, 2)) = tempArr(j)
        Next
        ReDim Preserve tempRange(1 To UBound(tempRange, 1), 1 To UBound(tempRange, 2) + 1)
      End If
    End If
  Next
  ReDim Preserve tempRange(1 To UBound(tempRange, 1), 1 To UBound(tempRange, 2) - 1)
  Worksheets("Sheet3").Range("A1").Resize(1, UBound(sheet1Range, 2)).Value = .Index(sheet1Range, 1, 0)
  Worksheets("Sheet3").Range("A2").Resize(UBound(tempRange, 2), UBound(tempRange, 1)).Value = .Transpose(tempRange)
  End With
  Worksheets("Sheet3").Range("G2").Resize(UBound(tempRange,2)).NumberFormat = "dd/mm/yyyy"
End Sub

 

[Starbel]

Hi @Flashbond - how are you? Hope all is well.

I just thought I'd bring to your attention that I keep getting the following error message -

Any idea why this is happening?

Many thanks

 

[Legacy 143009]

Hi,

I am sorry, I have no idea. It was working fine wirh the sample file.

 

[Starbel]

Hi @Flashbond

I wonder if its the date format.

What should I remove if I don't want it to look at the dates and compare the 6 months difference? Instead I just want the test to be -

1. Column I = Y

OR

1. Column B = does not match column B in sheet 1