VBscript for data matching

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

See ridiculously long formula in cell E2 of Sheet1 of the attached (copied down).

Code:

---

=INDEX(Sheet2!$C$3:$C$7,MIN(IF((VALUE(MID(A2,MIN(IF(ISNUMBER(VALUE(MID(A2,ROW($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)))))=Sheet2!$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.

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

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

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?

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....b3_attachments

Quote:

---

Originally Posted by p45cal

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

Please, attach an excel workbook. See message#6

please download the file from below link


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

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.

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

Quote:

---

Originally Posted by sampy12345

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

---

It 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.

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

Code:

---

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

---

Code:

---

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

Code:

---

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

---

Code:

---

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

---

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:Attachment 24241

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

Code:

---

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

---

Code:

---

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

---

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?

I am not getting an option of uploading a file.

Still same issue no error but not getting output as well

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.

Code:

---

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

---

Quote:

---

Originally Posted by sampy12345

I am not getting an option of uploading a file.

---

Click on Go Advanced and follow the prompts from there.

Quote:

---

Originally Posted by sampy12345

I am not getting an option of uploading a file.

---

Must try harder.
Everyone else manages.