Match more than entry according to the occurrence

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Match more than entry according to the occurrence

Post by YasserKhalil »

Hello everyone
I have Source sheet (that has the data in 7 columns and the main column to be matched is column A) and the second sheet is Target where I need to deal with column C to search for the items existing and show the results according to the occurrences.
I have put a simple example to explain the issue and to make it better to see the expected output
I prefer arrays if possible so as to make the code faster
Thanks advanced for help
You do not have the required permissions to view the files attached to this post.

Nabeel
2StarLounger
Posts: 170
Joined: 26 Jan 2017, 07:24

Re: Match more than entry according to the occurrence

Post by Nabeel »

as you are required code but you can achieve this with formula!

=IFERROR(INDEX(Source!$B$2:$G$9,AGGREGATE(15,6,ROW($C$3:$C$11)-2/($C3=Source!$A$2:$A$9),MOD((ROW($A1)-1),COUNTIF($C$3:$C$11,$C3))+1),MATCH(Target!D$2,Source!$B$1:$G$1,0)),"")

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Match more than entry according to the occurrence

Post by YasserKhalil »

Amazing my bro .. but I need a code as this is part of another code and I would like to use code instead. But to be honest your solution is amazing.

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Match more than entry according to the occurrence

Post by YasserKhalil »

I have the following code that worked well as for the example

Code: Select all

Sub MatchEntries()
    Dim aCols, arrS, arrT, arrInt, arrHeaders, arrExcl, e, sliceArray, ws As Worksheet, sh As Worksheet, dic As New Scripting.Dictionary, f As Boolean, m As Long, n As Long, i As Long, j As Long, k As Long, iRow As Long, r As Long
    Set ws = ThisWorkbook.Worksheets("Source")
    Set sh = ThisWorkbook.Worksheets("Target")
    m = ws.Range("A" & Rows.Count).End(xlUp).Row
    n = sh.Range("C" & Rows.Count).End(xlUp).Row
    sh.Range("D3:F" & n).ClearContents
    aCols = Array(2, 5, 7)
    arrS = ws.Range("A2:G" & m).Value
    arrT = sh.Range("C3:F" & n).Value
    arrHeaders = Array(ws.Cells(1, aCols(0)).Value, ws.Cells(1, aCols(1)).Value, ws.Cells(1, aCols(2)).Value)
    ReDim arrExcl(UBound(arrT) - 1)
    For i = 1 To UBound(arrT)
        For Each e In arrExcl
            If e = arrT(i, 1) Then GoTo OverProcessing
        Next e
        For j = 1 To UBound(arrS)
            If arrT(i, 1) = arrS(j, 1) Then
                f = True
                If Not dic.Exists(arrT(i, 1)) Then
                    dic.Add arrT(i, 1), arrS(j, aCols(0)) & ":" & arrS(j, aCols(1)) & ":" & arrS(j, aCols(2)) & "|1"
                Else
                    arrInt = Split(dic(arrT(i, 1)), "|")
                    dic(arrT(i, 1)) = arrInt(0) & ";" & arrS(j, aCols(0)) & ":" & arrS(j, aCols(1)) & ":" & arrS(j, aCols(2)) & "|" & CLng(arrInt(1)) + 1
                End If
            End If
        Next j
        If f Then
            iRow = Split(dic(arrT(i, 1)), "|")(1)
            arrInt = Split(Split(dic(arrT(i, 1)), "|")(0), ";")
            For r = 0 To iRow - 1
                arrT(i + r, 2) = Split(arrInt(r), ":")(0)
                arrT(i + r, 3) = Split(arrInt(r), ":")(1)
                arrT(i + r, 4) = Split(arrInt(r), ":")(2)
            Next r
        End If
        f = False
        arrExcl(k) = arrT(i, 1): k = k + 1
OverProcessing:
    Next i
    sh.Range("D2").Resize(, UBound(arrHeaders) + 1).Value = arrHeaders
    sliceArray = Application.Index(arrT, Evaluate("ROW(1:" & UBound(arrT, 1) & ")"), Evaluate("COLUMN(" & "B:D" & ")"))
    sh.Range("D3").Resize(UBound(sliceArray, 1), UBound(sliceArray, 2)).Value = sliceArray
End Sub
The code accepts only three columns as output.. What can I do to make it more flexible ? I mean I need to specify and change the needed columns through this line

Code: Select all

aCols = Array(2, 5, 7)

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Match more than entry according to the occurrence

Post by Doc.AElstein »

Hi Yasser
YasserKhalil wrote:
08 Sep 2020, 17:13
Amazing my bro .. .... to be honest your solution is amazing.
I am also amazed at such formula solutions. It would probably take me a month to understand such solutions. I think people like Nabeel who come up with such solutions must have a brain different to ours.
I find VBA programming an order of magnitude easier…
I don’t think there is anything difficult in doing this in VBA. Its just tedious, that’s all. There is probably lots of different ways to do it. ( I have done a macro for you in the nex post … )

_._____________________________________________________________________________________________________
YasserKhalil wrote:
09 Sep 2020, 14:20
I have the following code that worked well as for the example
.....
The code accepts only three columns as output.. What can I do to make it more flexible ? I mean I need to specify and change the needed columns through this line

Code: Select all

aCols = Array(2, 5, 7)
I personally find it usually more difficult to modify someone else’s macro , than to write the macro from scratch myself.
But sometime it is useful to know where the macro comes from, because that can sometimes help when trying to understand it.
Can you please tell me where you got it from?. A link to the source would be ideal. Thanks

_._________________________________________________________________________________________________________

In the nex post is a macro from me
Last edited by Doc.AElstein on 10 Sep 2020, 10:56, edited 2 times in total.
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Match more than entry according to the occurrence

Post by Doc.AElstein »

So here is a macro from me.
( I made it dynamic/ flexible from the outset, since I assumed you did not want to have to hard code things , for example to specify the columns) .
I don’t think there is anything difficult in doing this in VBA. Its just tedious, that’s all. There is probably lots of different ways to do it.
In my macro use the Index a lot to get different arrays.
In addition, at the end I use that thing which we discovered in a Thread of yours a few months ago, which is a neat way to get your final 2 D range array from the 1 D array of 1 D row arrays which my macro builds.

This macro will give you some ideas. You could probably experiment with it and shorten / simplify it yourself to speed it up a bit. I left it in its full explicit form so as to help you understand what is going on.
I think you could experiment yourself with shortening it to speed things up a bit. If you want me to do that for you then you will have to wait a few days until I have the time.

Here is a full explanation, and the macro, Sub BrdShlss()
Explanation: https://tinyurl.com/yyvrjaqu
Explanation : https://tinyurl.com/y5yudtp9
macro, Sub BrdShlss() : https://tinyurl.com/yxcrf7jx
( The macro is also in the uploaded returned file, SampleSept2020.xlsm : https://app.box.com/s/2be4vga1glbkpmytzut6yxqjowj9391c )


Alan
You do not have the required permissions to view the files attached to this post.
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Match more than entry according to the occurrence

Post by Doc.AElstein »

Edit… I may have had some unnecessary code lines in that uploaded macro … as someone has already downloaded it, let me see if I can post what is my latest…

Code: Select all

Option Explicit
Sub BrdShlss() '   http://www.eileenslounge.com/viewtopic.php?f=30&t=35303   https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14907&viewfull=1#post14907
Rem 1 worksheets data info
Dim WsS As Worksheet, WsT As Worksheet
 Set WsS = ThisWorkbook.Worksheets("Source"): Set WsT = ThisWorkbook.Worksheets("Target")
Dim LrS As Long, LrT As Long, LcS As Long, LcT As Long
 Let LrS = WsS.Range("A" & WsS.Rows.Count & "").End(xlUp).Row
 Let LrT = WsT.Range("C" & WsT.Rows.Count & "").End(xlUp).Row
 Let LcS = WsS.Cells(1, WsS.Columns.Count).End(xlToLeft).Column
 Let LcT = WsT.Cells(2, WsT.Columns.Count).End(xlToLeft).Column
Dim arSrc() As Variant ', arSrcA() As Variant
 Let arSrc() = WsS.Range("A1:" & CLtr(LcS) & LrS + 1 & "").Value   '  + 1 is to give us an extra empty row
' Let arSrcA() = WsS.Range("A1:A" & LrS & "").Value
Dim arTgt() As Variant: Let arTgt() = WsT.Range("C2:C" & LrT & "").Value
'1b) determine what columns are needed for our search range, since typically not all are needed
Dim strClms As String: Let strClms = "1"
Dim SrchHd() As Variant: Let SrchHd() = WsT.Range("D2:" & CLtr(LcT) & "2").Value
Dim SrcHd() As Variant: Let SrcHd() = WsS.Range("A1:" & CLtr(LcS) & "1").Value
Dim Cnt As Long
    For Cnt = 1 To UBound(SrchHd(), 2)
    Dim MtchRes As Long ' Note I assume there is always a match in Headers between sheet ranges, so that I always have a number and not an error string
     Let MtchRes = Application.Match(SrchHd(1, Cnt), SrcHd(), 0)
     Let strClms = strClms & " " & MtchRes  ' add a required column indicie
    
    Next Cnt
' Let strClms = Left(strClms, (Len(strClms) - 1)) ' remove last unwanted space   For the given example this gives us  "3 4 7"
Dim RwsT() As Variant: Let RwsT() = Evaluate("=Row(1:" & LrS + 1 & ")") '  + 1 is to give us an extra empty row
Dim arrSrch() As Variant ' This will be the reduced size range we need to search in - it has just the headers required
 Let arrSrch() = Application.Index(arSrc(), RwsT(), Split(strClms, " ", -1, vbBinaryCompare)) ' In our example   Split(strClms, " ", -1, vbBinaryCompare))  is  {1, 3, 4, 7)
' Let Range("H24").Resize(UBound(arrSrch(), 1), UBound(arrSrch(), 2)).Value = arrSrch()
'1c) Get initial row string indicies for current source range
'Dim RwsT() As Variant: Let RwsT() = Evaluate("=Row(1:" & UBound(arSrc(), 1) & ")") ' Typical "vertical" array of row indices needed in  Index(Arr, Rws(), Clms())  type code line
'Dim Rws() As Variant: Let Rws() = Application.Index(RwsT(), Evaluate("=Column(A:" & CLtr(UBound(RwsT, 1)) & ")"), Evaluate("=Column(A:" & CLtr(UBound(RwsT(), 1)) & ")/Column(A:" & CLtr(UBound(RwsT(), 1)) & ")")) '  Transpose the  "vertical array to get a 1 Dimenrional "horizontal" array
'Dim strRws As String: Let strRws = " " & Join(Rws(), " ") & " " ' This is a string of our row indicies, and later we will remove some indicies as we go along then work the steps above backwards to get a modified  RwsT()  to use in  Index(Arr, Rws(), Clms())  type code line  for a new reduced content search array
Rem 2 Building output array
Dim arrOut() As Variant ' A 1 D array for the 1 D arrays at each match
' 2b) main loop for all rows of  MyTarget
    For Cnt = 2 To UBound(arTgt(), 1) Step 1
     ReDim Preserve arrOut(1 To Cnt - 1)
    Dim arSrcA() As Variant: Let arSrcA() = Application.Index(arrSrch(), 0, 1) ' the first column of our current  arrSrch()    '  https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index
    Dim VarMtchres As Variant
     Let VarMtchres = Application.Match(arTgt(Cnt, 1), arSrcA(), 0)
        If IsError(VarMtchres) Then ' we need to add an empty row which we have as the last row of  arrSrch()
         Let arrOut(Cnt - 1) = Application.Index(arrSrch(), UBound(arrSrch(), 1), 0)                                           '  https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index
        Else
         Let arrOut(Cnt - 1) = Application.Index(arrSrch(), VarMtchres, 0)                                                     '  https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index
    '2b(ii) we must remove the row from the arrSrch()
         Let arrSrch() = DeleteArrayRow(arrSrch(), (VarMtchres))
        End If
    Next Cnt
Rem 3  '   Our output array is a 1D array of 1D arrays , but we noticed that we can treat that in  Index  as a 2D array  https://eileenslounge.com/viewtopic.php?p=266691#p266691
 Let arrOut() = Application.Index(arrOut(), RwsT(), Evaluate("=Column(B:" & CLtr(UBound(arrSrch(), 2)) & ")"))  ' ** this is actually 1 row too big
' Example paste out  CHANGE  Top left cell  H35  to suit
 Let WsT.Range("H35").Resize(UBound(arrOut(), 1) - 1, UBound(arrOut(), 2)).Value = arrOut()                 ' ** -1 is a bodge to knock off the extra row
End Sub

'  https://excelfox.com/forum/showthread.php/2083-Delete-One-Row-From-A-2D-Variant-Array
Function DeleteArrayRow(Arr As Variant, RowToDelete As Long) As Variant
  Dim Rws As Long, Cols As String
  Rws = UBound(Arr) - LBound(Arr)
  Cols = "A:" & Split(Columns(UBound(Arr, 2) - LBound(Arr, 2) + 1).Address(, 0), ":")(0)
  DeleteArrayRow = Application.Index(Arr, Application.Transpose(Split(Join(Application.Transpose(Evaluate("Row(1:" & (RowToDelete - 1) & ")"))) & " " & Join(Application.Transpose(Evaluate("Row(" & (RowToDelete + 1) & ":" & UBound(Arr) & ")"))))), Evaluate("COLUMN(" & Cols & ")"))
End Function

'  https://excelfox.com/forum/showthread.php/1902-Function-Code-for-getting-Column-Letter-from-Column-Number
Public Function CLtr(ByVal lclm As Long) As String '         http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
    Do: Let CLtr = Chr(65 + (((lclm - 1) Mod 26))) & CLtr: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Match more than entry according to the occurrence

Post by YasserKhalil »

I have copied the last code that you have modified and tested on my sample in the first post but didn't get any results
I prefer to be stick to the Sample workbook that I attached so as to get the issue well. First thing I do after I receive any solution , is to try the solution and see the results and make sure if it correct or not. Then I run the code line by line to learn from it as possible as I can.
Moreover I have attached a working code but needs to develop it. And I liked the solution provided as it supported arrays and this make the code faster than any usual approaches.
Thanks a lot for your sharing.

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Match more than entry according to the occurrence

Post by YasserKhalil »

So sorry. I have seen the results away at H35 and I have tried the code and it is working well.
Thanks a lot. What I liked most is that it is dynamic to add more columns
Thank you very much for the great help
I will study the code now to make use of it
Best Regards

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Match more than entry according to the occurrence

Post by Doc.AElstein »

YasserKhalil wrote:
10 Sep 2020, 11:18
I have copied the last code that you have modified and tested on my sample in the first post but didn't get any results...
I prefer to be stick to the Sample workbook that I attached so as to get the issue well. First thing I do after I receive any solution , is to try the solution and see the results and make sure if it correct or not. Then I run the code line by line to learn from it as possible as I can.
Moreover I have attached a working code but needs to develop it. And I liked the solution provided as it supported arrays and this make the code faster than any usual approaches.
Thanks a lot for your sharing.
I dont quite understand that reply? I am not quite sure what you are trying to say.


The speed at which you replied suggest to me that you have , as usual, not taken the time to read all that I wrote.
My macro does work on the sample workbook, and probably on any other data.
You may have overlooked that , I have set it to paste out from H35. So you would just need to change H35 to D3
Last edited by Doc.AElstein on 10 Sep 2020, 11:36, edited 2 times in total.
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Match more than entry according to the occurrence

Post by Doc.AElstein »

OK I just saw your last reply
All is well
:)
( I think, Yasser, you sometimes reply a bit too quickly and do not take the time that is courteous to take , to review all that is written for you by those who take the time to answer a question for you )
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Match more than entry according to the occurrence

Post by YasserKhalil »

So sorry for that. I will try to take the time to read each word.
But as I said I first tested the code before studying it and if it works well, then I begin to work on it.