PDA

View Full Version : VBscript for data matching



sampy12345
05-18-2019, 05:17 AM
Hi All,




I have a requirment can anyone help how can i achive this with vbscript.


Below is my requirment


I have a data in which 4 columns are there so in that 4 columns we should compare 2 columns and based on that a new column should be created and write the output




Example


In sheet1 below are the columns




Invoice No
City
Quantity
Price


The invoice of a product is delivered at 500038 and the delivery executive name is hji
Hyderabad
1
900


The invoice of a product is delivered at 507889 and the delivery executive name is hji
Pune
2
1800


The invoice of a product is delivered at 500138 and the delivery executive name is hji
Karimnagar
1
900


The invoice of a product is delivered at 500039 and the delivery executive name is hji
Kadapa
4
3600


The invoice of a product is delivered at 500238 and the delivery executive name is hji
Goa
2
1800







In Sheet2 below are the columns



Match Content in Invoice No
Match Content in City
Area


500038
Hyderabad
SR Nagar


507889
Pune
lalu nagar


500138
Karimnagar
RN Nagar


500039
Kadapa
mastangi nagar


500238
Goa
RN Road







In sheet1 cloumn1 and cloumn2 matches with sheet2 column1 and column 2 it should add a column in sheet1 with 3 column as output



Invoice No
City
Quantity
Price
Area


The invoice of a product is delivered at 500038 and the delivery executive name is hji
Hyderabad
1
900
SR Nagar


The invoice of a product is delivered at 507889 and the delivery executive name is hji
Pune
2
1800
lalu nagar


The invoice of a product is delivered at 500138 and the delivery executive name is hji
Karimnagar
1
900
RN Nagar


The invoice of a product is delivered at 500039 and the delivery executive name is hji
Kadapa
4
3600
mastangi nagar


The invoice of a product is delivered at 500238 and the delivery executive name is hji
Goa
2
1800
RN Road





In sheet1 column1 and column2 of row1 should compare with all the rows of sheet 2 column1 and column2 everytime and should displaay the output as above

p45cal
05-18-2019, 08:17 AM
See ridiculously long formula in cell E2 of Sheet1 of the attached (copied down).
=INDEX(Sheet2!$C$3:$C$7,MIN(IF((VALUE(MID(A2,MIN(IF(ISNUMBER(VALUE(MID(A2,R OW($A$1:$A$100),1))),ROW($A$1:$A$100))),SEARCH(" ",A2,MIN(IF(ISNUMBER(VALUE(MID(A2,ROW($A$1:$A$100),1))),ROW($A$1:$A$100))))-MIN(IF(ISNUMBER(VALUE(MID(A2,ROW($A$1:$A$100),1))),ROW($A$1:$A$100)))))=She et2!$A$3:$A$7)*(B2=Sheet2!$B$3:$B$7),ROW(Sheet2!$B$3:$B$7)))-ROW(Sheet2!$A$3:$A$7)+1)which is array-entered (committed to the sheet with Ctrl+Shift+Enter, not just Enter)

You could have provided such a file yourself instead of my having to make one up and guess (probably wrongly) at what you have.

edit post posting: Oops, I see you wanted vba code.

sampy12345
05-18-2019, 09:54 PM
thanks for the reply and from next time if i raise any concerns i will be attaching the scripts.


But how to keep this in a code.

As i have 16k records in a excel and it will compare almost 10k records.

Can this formula be used for those 16k records or what is the other alternate

sampy12345
05-18-2019, 11:19 PM
i have added 2 more rows in sheet 1 and sheet 2 but they are not working . Please find the attached sheet




#VALUE!
Below is the formula
=INDEX(Sheet2!$C$3:$C$9,MIN(IF((VALUE(MID(A7,MIN(IF(ISNUMBER(VALUE(MID(A7,R OW($A$1:$A$100),1))),ROW($A$1:$A$100))),SEARCH(" ",A7,MIN(IF(ISNUMBER(VALUE(MID(A7,ROW($A$1:$A$100),1))),ROW($A$1:$A$100))))-MIN(IF(ISNUMBER(VALUE(MID(A7,ROW($A$1:$A$100),1))),ROW($A$1:$A$100)))))=She et2!$A$3:$A$9)*(B7=Sheet2!$B$3:$B$9),ROW(Sheet2!$B$3:$B$9)))-ROW(Sheet2!$A$3:$A$9)+1)




I am unable to attachment . Above is the formula which i used

p45cal
05-19-2019, 01:26 AM
You are using Ctrl+Shift+Enter to commit the formula to the sheet and not just Enter as mentioned in my last message aren't you?

p45cal
05-19-2019, 04:21 AM
It will also show #VALUE if the cell in column A is blank or doesn't have a number.
Re attaching sheets: see http://www.vbaexpress.com/forum/faq.php?faq=vb3_reading_posting#faq_vb3_attachments

sampy12345
05-19-2019, 04:33 AM
You are using Ctrl+Shift+Enter to commit the formula to the sheet and not just Enter as mentioned in my last message aren't you?


After changing the column i didn't click Cntrl+Shft+Enter.

At present i am able to get the output but my doubdt is i have 16k records how about those 16k should i manually copy the formula in all the cells


hanks for the reply and from next time if i raise any concerns i will be attaching the scripts.


But how to keep this in a code.

As i have 16k records in a excel and it will compare almost 10k records.

Can this formula be used for those 16k records or what is the other alternate

p45cal
05-19-2019, 04:41 AM
Please, attach an excel workbook. See message#6

sampy12345
05-19-2019, 06:19 AM
please download the file from below link


https://we.tl/t-utJp7z7nN1 (https://we.tl/t-utJp7z7nN1)


but in this excel nothing is there only few line but i am yet to consolidate 16k record excel but if you let me know what are the changes need to be done for those 16k records i will do it

p45cal
05-19-2019, 08:40 AM
Please attach files at this site rather than link to them elsewhere.
That file is little more than the file I gave you!
In the attached, that file with three solutions on Sheet1:
Column E is filled by code on pressing the button.
Column F is the long formula using built-in functions
Column G is a user defined function.

sampy12345
05-19-2019, 09:36 AM
Thank you very much.

My requirement suffice my requirement.

Can you please provide the steps how did you create a button in E cloumn and how it write the code for that particular button.


As for 16k records i have different different requirement for each column. If you share me the steps how to create a button and assign the code for that i can implement the same for my all requirements

p45cal
05-19-2019, 10:44 AM
Can you please provide the steps how did you create a button in E cloumn and how it write the code for that particular button.
As for 16k records i have different different requirement for each column. If you share me the steps how to create a button and assign the code for that i can implement the same for my all requirementsIt would take me much longer to describe the steps I took to write the code than it did for me to write the code.
If you examine the code it could help you but what you really need to do is to work through either a book on programming Excel or an online tutorial.

sampy12345
05-20-2019, 05:52 AM
Hi,

I tried the code given by you with the my requirement but the code is not giving me the output which was working in the sheet which you have given


Sub Button1_Click()
Set myrng = Sheets("Sheet1").Range("A2:AF4614")
myRangeVals = myrng.Value
LookupVals = Sheets("Sheet2").Range("A2:C21").Value
myResults = myRangeVals
End If
For aj = 1 To UBound(myRangeVals)
myResults(aj, 1) = Empty
ExtractFirstNo = Empty
c = Split(myRangeVals(aj, 1))
If IsArray(c) Then
For ai = 0 To UBound(c)
Z = Evaluate("Value(" & c(ai) & ")")
If Not IsError(Z) Then
ExtractFirstNo = Z
Exit For
End If
Next ai
If Not IsEmpty(ExtractFirstNo) Then
For ak = 1 To UBound(LookupVals)
If LookupVals(ak, 1) = ExtractFirstNo Then
If LookupVals(ak, 2) = myRangeVals(aj, 2) Then
myResults(aj, 1) = LookupVals(ak, 3)
Exit For
End If
End If
Next ak
End If
Else
End If
Next aj
myrng.Offset(, myrng.Columns.Count).Resize(, 1).Value = myResults
End Sub


Function Findresult(myText, Description, MatchRange, ShortdescriptionColumn, DescriptionColumn, resultColumn)
a = Split(myText)
If IsArray(c) Then
For ai = 0 To UBound(a)
Z = Evaluate("Value(" & c(ai) & ")")
If Not IsError(Z) Then
ExtractFirstNo = Z
Exit For
End If
Next i
MRVals = MatchRange.Value
For i = 1 To UBound(MRVals)
If MRVals(i, ShortdescriptionColumn) = ExtractFirstNo Then
If MRVals(i, DescriptionColumn) = City Then
FindArea = MRVals(i, resultColumn)
End If
End If
Next ai
End If
End Function




Total columns i have is from A to AG and i am comparing C & D columns and writing the output to E column


I am unable to upload the sheet thats the reason why i am copying the code or content of the sheet.


Please suggest

Below was the code shared by you


Sub asdasd()
Set myrng = Sheets("Sheet1").Range("A2:D8")
myRangeVals = myrng.Value
LookupVals = Sheets("Sheet2").Range("A3:C9").Value
myResults = myRangeVals
For j = 1 To UBound(myRangeVals)
myResults(j, 1) = Empty
ExtractFirstNo = Empty
a = Split(myRangeVals(j, 1))
If IsArray(a) Then
For i = 0 To UBound(a)
Z = Evaluate("Value(" & a(i) & ")")
If Not IsError(Z) Then
ExtractFirstNo = Z
Exit For
End If
Next i
If Not IsEmpty(ExtractFirstNo) Then
For k = 1 To UBound(LookupVals)
If LookupVals(k, 1) = ExtractFirstNo Then
If LookupVals(k, 2) = myRangeVals(j, 2) Then
myResults(j, 1) = LookupVals(k, 3)
Exit For
End If
End If
Next k
End If
Else
End If
Next j
myrng.Offset(, myrng.Columns.Count).Resize(, 1).Value = myResults
End Sub

Function FindArea(myText, City, MatchRange, InvoiceColumn, CityColumn, AreaColumn)
a = Split(myText)
If IsArray(a) Then
For i = 0 To UBound(a)
Z = Evaluate("Value(" & a(i) & ")")
If Not IsError(Z) Then
ExtractFirstNo = Z
Exit For
End If
Next i
MRVals = MatchRange.Value
For i = 1 To UBound(MRVals)
If MRVals(i, InvoiceColumn) = ExtractFirstNo Then
If MRVals(i, CityColumn) = City Then
FindArea = MRVals(i, AreaColumn)
End If
End If
Next i
End If
End Function

p45cal
05-20-2019, 06:23 AM
What prevents you from uploading the file?
Try changing:
Set myrng = Sheets("Sheet1").Range("A2:AF4614")
to:
Set myrng = Sheets("Sheet1").Range("C2:D4614")

If that fails then try to make the FindArea userdfeined function work. If you can get it to give the correct answers, send me the formula you actually ended up using from the top row that you've used it in; something instead of:
=FindArea(A2,B2,Sheet2!$A$3:$C$9,1,2,3)
You may find bringing up the function arguments dialogue box helpful while editing that function:24241

sampy12345
05-20-2019, 06:48 AM
After changing also i am unable to receive any change but i am not getting error. Is there any code change . can you please recheck


Sub Button1_Click()
Set myrng = Sheets("Sheet1").Range("C2:DF4614")
myRangeVals = myrng.Value
LookupVals = Sheets("Sheet2").Range("A2:C21").Value
myResults = myRangeVals
For aj = 1 To UBound(myRangeVals)
myResults(aj, 1) = Empty
ExtractFirstNo = Empty
c = Split(myRangeVals(aj, 1))
If IsArray(c) Then
For ai = 0 To UBound(c)
Z = Evaluate("Value(" & c(ai) & ")")
If Not IsError(Z) Then
ExtractFirstNo = Z
Exit For
End If
Next ai
If Not IsEmpty(ExtractFirstNo) Then
For ak = 1 To UBound(LookupVals)
If LookupVals(ak, 1) = ExtractFirstNo Then
If LookupVals(ak, 2) = myRangeVals(aj, 2) Then
myResults(aj, 1) = LookupVals(ak, 3)
Exit For
End If
End If
Next ak
End If
Else
End If
Next aj
myrng.Offset(, myrng.Columns.Count).Resize(, 1).Value = myResults
End Sub


Function Findresult(myText, Description, MatchRange, ShortdescriptionColumn, DescriptionColumn, resultColumn)
a = Split(myText)
If IsArray(c) Then
For ai = 0 To UBound(a)
Z = Evaluate("Value(" & c(ai) & ")")
If Not IsError(Z) Then
ExtractFirstNo = Z
Exit For
End If
Next i
MRVals = MatchRange.Value
For i = 1 To UBound(MRVals)
If MRVals(i, ShortdescriptionColumn) = ExtractFirstNo Then
If MRVals(i, DescriptionColumn) = City Then
FindArea = MRVals(i, resultColumn)
End If
End If
Next ai
End If
End Function

p45cal
05-20-2019, 10:16 AM
You have it as:
Set myrng = Sheets("Sheet1").Range("C2:DF4614")
(the results might have appeared in column DG)
it should be:
Set myrng = Sheets("Sheet1").Range("C2:D4614")

Again, What prevents you from uploading the file?

sampy12345
05-20-2019, 08:45 PM
I am not getting an option of uploading a file.

Still same issue no error but not getting output as well

大灰狼1976
05-20-2019, 10:00 PM
Hi sampy!
16K data is not too much. It can be completed in less than one second.
I did it with Regular Expression + Dictionary like below.

Sub test()
Dim arr, arrRst, d As Object, reg As Object, i&, s$
Set d = CreateObject("scripting.dictionary")
arr = Sheets(2).[a2].CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 1) & "," & arr(i, 2)) = arr(i, 3)
Next i
arr = Sheets(1).Range("a2:b" & Sheets(1).Cells(Rows.Count, 1).End(3).Row)
ReDim arrRst(1 To UBound(arr), 0)
Set reg = CreateObject("vbscript.regexp")
reg.Pattern = "\d+"
For i = 1 To UBound(arr)
s = reg.Execute(arr(i, 1))(0) & "," & arr(i, 2)
arrRst(i, 0) = d(s)
Next i
Sheets(1).[e2].Resize(UBound(arrRst)) = arrRst
End Sub

Aussiebear
05-21-2019, 02:11 AM
I am not getting an option of uploading a file.
Click on Go Advanced and follow the prompts from there.

p45cal
05-21-2019, 03:59 AM
I am not getting an option of uploading a file.
Must try harder.
Everyone else manages.