Code:
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
Reply With Quote
Originally Posted by vba_php
, 
)
, 
Bookmarks