Handling pairs of pattern matching in multiple excel files through VB macros - excel

Question

I have three files - Excel_In1.xls, Excel_In2.xls and Excel_Out.xls.
There are two column say column L,M in Excel_In1.xls which contains keywords (of form product123 and companyABC) I need to search for these pairs of keywords in two columns (say A,B) in Excel_In2.xls. There are multiple rows in Excel_In2.xls with the keywords in that columns A,B.
I need to copy particular columns (say for instance three columns B,X,Z) in all the rows which contain the keyword product123 in the column A and companyABC in column B in Excel_In2.xls to the file Excel_Out.xls.
What is the best and simple way to accomplish this in VB script macros in Excel_Out.xls?
I also want to open the files Excel_In1.xls and Excel_In2.xls in macro in Excel_Out.xls.

Answer 1

my assumptions:
Excel_In1.xls == catalog.xlsx (table has unique key pair columnA & columnB in each row)
Excel_In2.xls == factdata.xlsx (table has multiple duplicate key pairs; and contains data in fixed columns to be copied)
Excel_Out.xls == book Out.xlsm
Option Explicit
Private Type TState
catalog As Object
selectedData As Object
End Type
Private this As TState
Public Sub ExampleSubMain()
Init
PickData
ExecuteCopying
End Sub
Private Sub Init()
InitCatalogDictionary
Set this.selectedData = CreateObject("Scripting.Dictionary")
End Sub
Private Sub InitCatalogDictionary()
MakeTheBookOpened "D:\vba\somefolder\", "catalog.xlsx"
Dim wb As Workbook
Set wb = Workbooks("catalog.xlsx")
Dim dataRange As Range
Set dataRange = wb.Worksheets("catalogSheet").Range("a2:b10") 'for example "a2:b10"
Set this.catalog = MakeDict(dataRange)
End Sub
Private Function MakeDict(ByVal dataRange As Range) As Object
Dim result As Object
Set result = CreateObject("Scripting.Dictionary")
Dim row As Range
For Each row In dataRange.Rows
'asumes column A,B are true keys and their pairs are unique, value = empty string
result.Add Join(Array(row.Cells(1), row.Cells(2))), ""
Next row
Set MakeDict = result
End Function
Private Sub MakeTheBookOpened(ByVal pathWithSeparator As String, _
ByVal wbName As String)
If TheBookIsOpenedAlready(wbName) Then Exit Sub
Workbooks.Open Filename:=pathWithSeparator & wbName, ReadOnly:=True
End Sub
Private Function TheBookIsOpenedAlready(ByVal Name As String) As Boolean
Dim wb As Workbook
For Each wb In Workbooks
If wb.Name = Name Then TheBookIsOpenedAlready = True: Exit Function
Next wb
End Function
Private Sub PickData()
MakeTheBookOpened "D:\vba\somefolder\", "factdata.xlsx"
Dim wb As Workbook
Set wb = Workbooks("factdata.xlsx")
Dim dataRange As Range
Set dataRange = wb.Worksheets("factSheet").Range("a2:k10") 'for example "a2:k10"
Dim row As Range
For Each row In dataRange.Rows
Dim key As String
key = Join(Array(row.Cells(4), row.Cells(6))) 'asumes product123, companyABC columns are there
If this.catalog.Exists(key) Then this.selectedData.Add row, ""
Next row
End Sub
Private Sub ExecuteCopying()
If this.selectedData.Count = 0 Then Exit Sub
Dim rowsNum As Long
rowsNum = this.selectedData.Count
Dim columnsNum As Long
columnsNum = 3 'for example 3
Dim resultArr As Variant
ReDim resultArr(1 To rowsNum, 1 To columnsNum)
Dim pos As Long
pos = 1
Dim item As Variant
For Each item In this.selectedData
Dim row As Range
Set row = item
resultArr(pos, 1) = row.Cells(2) 'B
resultArr(pos, 2) = row.Cells(7) 'G
resultArr(pos, 3) = row.Cells(10) 'J
pos = pos + 1
Next item
'book Out.xlsm
ThisWorkbook.Worksheets(1).Range("a1").Resize(rowsNum, columnsNum) = resultArr
End Sub

Answer 2

Given two basic input files roughly matching your description:
and
And assuming the macro would reside in the out file, we could construct a multi-function macro to accomplish this with a few steps.
The first part of the macro knows filenames and parameters. You used column L in the first input file, but let's make that configurable. The same with most of the other parameters, like the first line to start on so our input files can have headers.
Second, we need to open the first input file and read the keywords. There's several ways to do this, but a very simple way to do it is to do a plan CSV line, so that from the first file, you can extract your "keywords" (your term): product123,product456. This can then be iterated over with a For Each loop through the second file.
In the second file, a very simple construct would be to loop over all entries. Depending on your needs, you may need to iterate through the second file only once if it is prohibitively large. Both of these function assume the first blank line terminates the input. If the row in the 2nd input file matches your target, you will perform your copy.
Finally, the copy also takes a CSV line for which columns to keep (keeping it configurable). Each column, as well as the first keyword, will be copied to the target worksheet, starting at row 1 with a configurable column start.
The final output in the output sheet looks something like this:
The output starts in the second column because that was what was specified in the configuration.
There may be more elegant approaches, but this is a straight-forward approach to it.
Const EXCEL_1 As String = "\Excel1.xls"
Const EXCEL_1_KW_COL As String = "A"
Const EXCEL_2 As String = "\Excel2.xls"
Const EXCEL_2_KW_COL As String = "A"
Const EXCEL_2_COPY_COLS As String = "B,E,G"
Const EXCEL_3 As String = "\Excel3.xls"
Const EXCEL_3_TARGET As String = "B"
Public Function LoadInformation3()
Dim Location As String, Keywords As String
Application.ScreenUpdating = False
Location = Application.ActiveWorkbook.Path
Keywords = LoadKeywords(Location & EXCEL_1, EXCEL_1_KW_COL)
Debug.Print "Keys=" & Keywords
Dim L, CurrentDestRow As Long
For Each L In Split(Keywords, ",")
SearchKeywordAndCopy CurrentDestRow, Location & EXCEL_2, Location & EXCEL3, L, EXCEL_2_KW_COL, EXCEL_2_COPY_COLS, EXCEL_3_TARGET
Next
Application.ScreenUpdating = True
End Function
Public Function LoadKeywords(ByVal File As String, ByVal ColumnId As String, Optional ByVal FirstRow As Long = 2)
Dim Wb1 As Workbook
Dim Value As String, N As Long
Set Wb1 = Workbooks.Open(File)
N = FirstRow
LoadKeywords = ""
Do While True
Value = Wb1.Sheets(1).Range(ColumnId & N).Text
If Value = "" Then Exit Do
LoadKeywords = LoadKeywords & IIf(LoadKeywords = "", "", ",") & Value
N = N + 1
Loop
Wb1.Close SaveChanges:=False
End Function
Public Sub SearchKeywordAndCopy(ByRef CurrentDestRow As Long, ByVal FileSource As String, ByVal FileTarget As String, ByVal Keyword As String, ByVal SourceColumn As String, ByVal SourceCopyFrom As String, ByVal DestCopyTo As String)
Dim WbSource As Workbook, WbDest As Workbook
Dim Value As String, N As Long
Set WbDest = Application.ActiveWorkbook
Set WbSource = Workbooks.Open(FileSource)
N = 2
Do While True
Value = WbSource.Sheets(1).Range(SourceColumn & N).Text
If Value = "" Then Exit Do
If Value <> Keyword Then GoTo NextRow
Dim L, M As Long
CurrentDestRow = CurrentDestRow + 1
WbDest.Sheets(1).Range(DestCopyTo & CurrentDestRow).Value = Keyword
M = 0
For Each L In Split(SourceCopyFrom, ",")
Dim CopyValue As String
CopyValue = WbSource.Sheets(1).Range(L & N).Text
M = M + 1
WbDest.Sheets(1).Range(DestCopyTo & CurrentDestRow).Offset(, M).Value = CopyValue
Next
NextRow:
N = N + 1
Loop
WbSource.Close SaveChanges:=False
End Sub

Answer 3

Your setup as best I could understand it:
And... This is the code I wrote:
Option Explicit
Option Base 1
Sub CopyData()
Dim XLout As Workbook 'Excel_Out.xls
Dim XLin1 As Workbook 'Excel_In1.xls
Dim XLin2 As Workbook 'Excel_In2.xls
Dim ProductList 'Product/Company List from XLin1
Dim ProductListO() 'Concatenated Version of above
Dim DataList 'Product/Company List from XLin2
Dim DataXcol 'Extra Data to pull from Column X in XLin2
Dim DataZcol 'Extra Data to pull from Column Z in XLin2
Dim Output() 'Output Array for XLout
Dim i As Long 'Iterations
Dim counter As Long 'Item number
Dim TimeCount
TimeCount = Timer
' >>> All Workbooks
Set XLout = ThisWorkbook
Set XLin1 = Workbooks.Open("C:\Users\ccritchlow\Documents\A\Test\Excel_In1.xls")
Set XLin2 = Workbooks.Open("C:\Users\ccritchlow\Documents\A\Test\Excel_In2.xls")
' >>> Store Source Data in Arrays
With XLin2.Sheets(1)
DataList = .Range("A2:B" & .Range("A" & Rows.Count).End(xlUp).Row)
DataXcol = .Range("X2:X" & .Range("A" & Rows.Count).End(xlUp).Row)
DataZcol = .Range("Z2:Z" & .Range("A" & Rows.Count).End(xlUp).Row)
End With
' >>> Store Product List Data in Arrays
ProductList = XLin1.Sheets(1).Range("L2:M" & XLin1.Sheets(1).Range("M" & Rows.Count).End(xlUp).Row)
ReDim ProductListO(1 To UBound(ProductList, 1))
For i = 1 To UBound(ProductList, 1)
ProductListO(i) = ProductList(i, 1) & "-" & ProductList(i, 2)
Next i
' >>> Move entries from XLin2 (that exist on XLin1) into "Output" Array
ReDim Preserve Output(UBound(DataList, 1), 3)
counter = 1
For i = 1 To UBound(DataList, 1)
DataList(i, 1) = DataList(i, 1) & "-" & DataList(i, 2)
If Not IsError(Application.Match(DataList(i, 1), ProductListO(), 0)) Then
Debug.Print
Output(counter, 1) = DataList(i, 2)
Output(counter, 2) = DataXcol(i, 1)
Output(counter, 3) = DataZcol(i, 1)
counter = counter + 1
End If
Next i
' >>> Output to XLout
XLout.Sheets(1).Range("A2").Resize(UBound(Output, 1), 3) = Output()
Application.StatusBar = "Total Time to review " & UBound(DataList, 1) & " lines = " & Timer - TimeCount
End Sub
It does the following
Is stored on "Excel_Out.xls"
Opens both "Excel_In#.xls" workbooks
Stores all required data in arrays
Identifies data on XLin2 whose "company&productname" exist on XLin1
Outputs that data to "Excel_Out.xls"
This is how it looks: