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


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()
End Sub

Private Sub Init()
    Set this.selectedData = CreateObject("Scripting.Dictionary")
End Sub

Private Sub InitCatalogDictionary()
    MakeTheBookOpened "D:vbasomefolder", "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:vbasomefolder", "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

Given two basic input files roughly matching your description:

enter image description here


enter image description here

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:

enter image description here

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
  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
  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
    N = N + 1
  WbSource.Close SaveChanges:=False
End Sub

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:UsersccritchlowDocumentsATestExcel_In1.xls")
    Set XLin2 = Workbooks.Open("C:UsersccritchlowDocumentsATestExcel_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
            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:

enter image description here

Related Solutions

Getting last modification date of a PostgreSQL database table

There is no reliable, authorative record of the last modified time of a table. Using the relfilenode is wrong for a lot of reasons: Writes are initially recorded to the write-head log (WAL), then lazily to the heap (the table files). Once the record is in WAL,...

How do I make this sed script a “one liner”?

An ANSI C string -- with $'' -- can contain backslash escapes, like \n -- so you can have a newline in sed's arguments while still having the shell command invoking sed be only one line. sed -i $'/INTERPRETER_PYTHON_DISTRO_MAP/,/version_added/ {\n /default/a\\...

How to OCR a PDF file and get the text stored within the PDF?

ocrmypdf does a good job and can be used like this: ocrmypdf in.pdf out.pdf To install: pip install ocrmypdf or sudo apt install ocrmypdf # ubuntu sudo dnf -y install ocrmypdf # fedora After learning that Tesseract can now also produce searchable PDFs, I found...

If …Else If wont work [closed]

First of all, put the javascript code between a <script></script> tag because javascript code will not run in an html <div></div> tag. Then, instead of x == 0||9||2, use x == 0 || x == 9 || x == 2. Kindly indent your code for easier...

How to convert the object of character to string

Your object of characters is already almost an array. It has numeric indices, but is missing the .length property. If you add that it, it will be an "array like" object, which can then be passed to Array.from to get a proper array. Once you have a real array,...

How can I write the approximate value of PI?

Because your { and } is wrong. I think brackets will be as given below If the formula is PI = 4/1 - 4/3 + 4/5 - 4/7 + ... ( Leibniz's Series ) then you can formalate as given below #include <iostream> using namespace std; int main() { double n, i; //...

c# Regex catch string between two string [duplicate]

You can try this: <[a-z\s]+id=[\'\"]mobile[\w]+[\'\"][\sa-zA-Z\d\'\=\;\:]*>([a-zA-Z\d\s]+)<[\/a-z\s]+> Anyway it will not match special chars or symbols. You can test and optimize it here: https://regex101.com/r/fnYQ1o/10 EDIT - Code example This...

Do I need CSRF token if I’m using Bearer JWT?

This is relevant but doesn't necessarily answer 100% of your question: https://security.stackexchange.com/a/166798/149676 The short of it is that as long as authentication isn't automatic (typically provided by the browser) then you don't have to worry about...

Java cannot find symbol during compiling

The problem is this line: System.out.println(pref); You have not defined pref in this scope. The field pref is only defined in main method but cannot be read outside of it and therefore outside your main method the pref field has to be defined as well. (You may...


Well, for such small tasks no CMS (I mean WP or Drupal) is necessarily needed - customizing one for your needs will me much more painful, than adding a few PHP lines to your HTML files. To make your website able to get data, you will have to make it perform...

Weird results in c [closed]

In addition to LihOs answer above this block looks wrong: if(tab1[i] != '\0') tab1[i]==result[i]; else if (tab2[i] !='\0') tab2[i]==result[i]; else printf(" "); Don't you mean to assign the value in tab1[i]or tab2[i] to result[i]like this? if(tab1[i] != '\0')...

Notepad in windows form application [closed]

This should demonstrate how to open Notepad and put text into it. This is a simple example of starting a Notepad process and then adding text to it. Will open a new Notepad.exe process and then add the text "Sending a message, a message from me to you" to the...

Check whether number is even or odd without using any operator

I think you are talking about no arithmetic operator In this case you can ask yourself, in binary what represents the least significant bit (bit 0)? So you can test that bit to know if a number is odd or even: if (number & 0x01) { // odd number } else { //...

What is the output of the program with reason?

See annotations: #include <stdio.h> void f(int *p, int *q) // p contains address of i, q contains address of j { p=q; // p now contains address of j *p=2; // assigns 2 to j, not i } int main() { int i=0,j=1; // i contains 0, j contains 1 f( &i, &j...

Relative imports for the billionth time

Script vs. Module Here's an explanation. The short version is that there is a big difference between directly running a Python file, and importing that file from somewhere else. Just knowing what directory a file is in does not determine what package Python...