VBA code to find lookup value from two data sets.

[excelvba123]

Hi All,

Respected Members please accept my sincere thanks for all your esteemed help given through this channel.

I have attached a sample worksheet which I use in work. My aim is to find job nuumbers on sheet1 in the dataset on sheet 2(column A) and return the corresponding values iolumn B & C on sheet 2. Please note that one job number can be paid more than one time in the past months(eg. 3300023104), and therefore the requirement is to total the amount of money paid in all months, on a particular job reference. The output i require on sheet 1 is "month paid in" and "amount paid ". If a job is paid just once then simply get the month and amount on sheet 1. But i dont know if a paricular job like 3300023104 has been paid loads of times in several months, how can we list the months as well as the amount. If months is not possible then only amount can do...


My objective is to find out how much money has been paid before on the jobs mentioned on sheet 1 column A (my current month invoice). I already have a vba code to trace any duplicates within column A on sheet 1. For instance job ref 3300023104 has been repeated a few times on sheet 1.

Please advise at your convenience.

Thank you
Manav

[venkat1926]

data appears to be large. about 1600 rows.

to check each ngm and also each month (there are nine months
so the intersectiosn are 1600x9=14400 cells have to be checked.
of course macro has been writen

there re two macro test and testone
testone is embedded in test
SO YOU NEED TO RUN ONLY "TEST"

attached file " excevba123 VB Challenge.xlsm" is AFTER running the macro
to retest run "test" agains. becaue of 11400 cells it takes between one minute and one and half minutes

the macros are in the module of the file and also repeated here

Dim ngm As Range, mmonth As Range, unq As Range, cunq As Range, filt As Range
Dim rdata As Range, unqmonth As Range, cmonth As Range, ssum As Double
Sub test()
Application.ScreenUpdating = False
 Worksheets("sheet2").Activate
 

Range(Range("a1").End(xlDown).Offset(5, 0), Cells(Rows.Count, "A")).EntireRow.Delete
testone
Set ngm = Range(Range("A1"), Range("a1").End(xlDown))
Set unq = ngm(1, 1).End(xlDown).Offset(5, 0)
'MsgBox unq.Address

ngm.AdvancedFilter xlFilterCopy, , unq, True
Range("D1") = "month of date"
Set mmonth = Range(Range("D1"), Range("D1").End(xlDown))

mmonth.AdvancedFilter xlFilterCopy, , unq.Offset(0, 1), True

Set rdata = Range("a1").CurrentRegion
Set unqmonth = Range(unq.Offset(1, 1), unq.Offset(1, 1).End(xlDown))

unqmonth.Select
Selection.Copy
unq.Offset(0, 1).Select
 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
Range(unq.Offset(1, 1), unq.Offset(1, 1).End(xlDown)).Cells.Clear
Set unqmonth = Range(unq.Offset(0, 1), unq.End(xlToRight))
Set unq = Range(unq.Offset(1, 0), unq.End(xlDown))

For Each cunq In unq
For Each cmonth In unqmonth
rdata.AutoFilter field:=1, Criteria1:=cunq
rdata.AutoFilter field:=4, Criteria1:=cmonth.Value
Set filt = rdata.SpecialCells(12)
ssum = WorksheetFunction.Sum(rdata.Columns("c:c").Cells.SpecialCells(12))
If ssum = 0 Then GoTo nextcmonth
Application.Intersect(Rows(cunq.Row), Columns(cmonth.Column)) = ssum
Application.Intersect(Rows(cunq.Row), Columns(cmonth.Column)).NumberFormat = "[$£-809]#,##0.00"
ActiveSheet.AutoFilterMode = False
nextcmonth:

Next cmonth
Next cunq
Range("d1").EntireColumn.Delete
'.Range("a1").End(xlDown).Offset(5, 0).CurrentRegion.Cells.NumberFormat = "[$£-809]#,##0.00"
'End With
Application.ScreenUpdating = True
MsgBox "macro over"
End Sub

Sub testone()
Dim j As Integer, r As Range
With Worksheets("sheet2")
j = .Range("a1").End(xlDown).Row
Set mmonth = Range(.Range("B1"), .Range("B1").End(xlDown))
Set r = mmonth.Offset(1, 0).Resize(mmonth.Rows.Count - 1)
'MsgBox r.Address
'MsgBox r.Offset(0, 2).Address
r.Offset(0, 2).Formula = "=month(" & r.Address & ")"

End With

End Sub

[excelvba123]

I appreciate your prompt reply Mr.Venkat, thank you so much.

Many Regards
Manav

data appears to be large. about 1600 rows.

to check each ngm and also each month (there are nine months
so the intersectiosn are 1600x9=14400 cells have to be checked.
of course macro has been writen

there re two macro test and testone
testone is embedded in test
SO YOU NEED TO RUN ONLY "TEST"

attached file " excevba123 VB Challenge.xlsm" is AFTER running the macro
to retest run "test" agains. becaue of 11400 cells it takes between one minute and one and half minutes

the macros are in the module of the file and also repeated here

Dim ngm As Range, mmonth As Range, unq As Range, cunq As Range, filt As Range
Dim rdata As Range, unqmonth As Range, cmonth As Range, ssum As Double
Sub test()
Application.ScreenUpdating = False
 Worksheets("sheet2").Activate
 

Range(Range("a1").End(xlDown).Offset(5, 0), Cells(Rows.Count, "A")).EntireRow.Delete
testone
Set ngm = Range(Range("A1"), Range("a1").End(xlDown))
Set unq = ngm(1, 1).End(xlDown).Offset(5, 0)
'MsgBox unq.Address

ngm.AdvancedFilter xlFilterCopy, , unq, True
Range("D1") = "month of date"
Set mmonth = Range(Range("D1"), Range("D1").End(xlDown))

mmonth.AdvancedFilter xlFilterCopy, , unq.Offset(0, 1), True

Set rdata = Range("a1").CurrentRegion
Set unqmonth = Range(unq.Offset(1, 1), unq.Offset(1, 1).End(xlDown))

unqmonth.Select
Selection.Copy
unq.Offset(0, 1).Select
 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
Range(unq.Offset(1, 1), unq.Offset(1, 1).End(xlDown)).Cells.Clear
Set unqmonth = Range(unq.Offset(0, 1), unq.End(xlToRight))
Set unq = Range(unq.Offset(1, 0), unq.End(xlDown))

For Each cunq In unq
For Each cmonth In unqmonth
rdata.AutoFilter field:=1, Criteria1:=cunq
rdata.AutoFilter field:=4, Criteria1:=cmonth.Value
Set filt = rdata.SpecialCells(12)
ssum = WorksheetFunction.Sum(rdata.Columns("c:c").Cells.SpecialCells(12))
If ssum = 0 Then GoTo nextcmonth
Application.Intersect(Rows(cunq.Row), Columns(cmonth.Column)) = ssum
Application.Intersect(Rows(cunq.Row), Columns(cmonth.Column)).NumberFormat = "[$£-809]#,##0.00"
ActiveSheet.AutoFilterMode = False
nextcmonth:

Next cmonth
Next cunq
Range("d1").EntireColumn.Delete
'.Range("a1").End(xlDown).Offset(5, 0).CurrentRegion.Cells.NumberFormat = "[$£-809]#,##0.00"
'End With
Application.ScreenUpdating = True
MsgBox "macro over"
End Sub

Sub testone()
Dim j As Integer, r As Range
With Worksheets("sheet2")
j = .Range("a1").End(xlDown).Row
Set mmonth = Range(.Range("B1"), .Range("B1").End(xlDown))
Set r = mmonth.Offset(1, 0).Resize(mmonth.Rows.Count - 1)
'MsgBox r.Address
'MsgBox r.Offset(0, 2).Address
r.Offset(0, 2).Formula = "=month(" & r.Address & ")"

End With

End Sub