excel - Based on matching variables in different tables, copy and paste information

Question

1. I have an "Import" worksheet. On this sheet I have 3 droplists with criterias:

London = C3, High School = C4, Old = C5

City, School and Student are changeable items from a droplist.

2. I have a "Specifications" worksheet. On this sheet I have a table which looks like:

The Table starts on the "H" column. (The table has more rows, this is an example from it.)

3. On the "Import" worksheet information gets imported in this format:

The Data starts on the "E" column. (Again, this is an example. The real data has more rows.)

4. Now coming to the actual problem:

When Criteria A(City), B(School), C(Student) from the "Import" sheet correspond to a matching row on the "Specification" sheet table -> then assign the student number of that same row as the "key" that needs to be found in the imported data from the "Import" sheet.

There are 2 types of student numbers. One with letters, One with numbers. Numbers are always a complete match, letters usually a partial match. Numbers are found on "Import" sheet column "H" and letters can be found in "Import" sheet column "M".

When a match is found on the "Import" sheet then copy from "Specifications" sheet table column "City"(H), "School"(I), "Student"(J), "Constant 1"(K), "Constant 2"(L), "Constant 3"(M) and copy from the "Specifications" sheet "Date" (E), "Amount" (K), into a table on the 3rd worksheet called "Output".

The table looks like this:

There won't always be a match with every row on the "Import" worksheet. For those instances where there are rows without a match the row should still be copied to the "Output" table, but with Constant 1,2,3 filled as "Unknown". Like on the image above.

I have the following code:

Option Explicit

Dim wsImport As Worksheet

Sub Sample()
    Dim wsSpec As Worksheet
    
    Set wsImport = ThisWorkbook.Sheets("Import")
    Set wsSpec = ThisWorkbook.Sheets("Specifications")
    
    Dim CriteriaA As String, CriteriaB As String, CriteriaC As String
    Dim aCell As Range, bCell As Range
    Dim origin As String, KeyToFind As String
    
    With wsSpec
        CriteriaA = wsImport.Range("C3").Value2
        CriteriaB = wsImport.Range("C4").Value2
        CriteriaC = wsImport.Range("C5").Value2
        
        '~~> Using .Find to look for CriteriaA
        Set aCell = .Columns(8).Find(What:=CriteriaA, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
        '~~> Check if found or not
        If Not aCell Is Nothing Then
            Set bCell = aCell
            
            '~~> Secondary checks
            If aCell.Offset(, 1).Value2 = CriteriaB And _
               aCell.Offset(, 2).Value2 = CriteriaC Then '<~~ If match found
               '~~> Get the origin and the key
               origin = aCell.Offset(, 6).Value2
               KeyToFind = aCell.Offset(, 7).Value2
            Else '<~~ If match not found then search for next match
               Do
                   Set aCell = .Columns(8).FindNext(After:=aCell)
        
                   If Not aCell Is Nothing Then
                        If aCell.Address = bCell.Address Then Exit Do
                        
                        If aCell.Offset(, 1).Value2 = CriteriaB And _
                           aCell.Offset(, 2).Value2 = CriteriaC Then
                           origin = aCell.Offset(, 6).Value2
                           KeyToFind = aCell.Offset(, 7).Value2
                           Exit Do
                        End If
                   Else
                       Exit Do
                   End If
               Loop
            End If
            
            '~~> Check the origin
            If origin = "Letters" Then
                CopyRows "M", KeyToFind, True
            ElseIf origin = "Numbers" Then
                CopyRows "H", KeyToFind, False
            Else
                MsgBox "Please check origin. Numbers/Letters not found. Exiting..."
            End If
        Else
            MsgBox "Criteria A match was not found. Exiting..."
        End If
    End With
End Sub

'~~> Autofilter and copy filtered data
Private Sub CopyRows(Col As String, SearchString As String, PartialString As Boolean)
    Dim copyFrom As Range
    Dim lRow As Long
    
    With wsImport
        '~~> Remove any filters
        .AutoFilterMode = False
        
        lRow = .Range(Col & .Rows.Count).End(xlUp).Row

        With .Range(Col & "1:" & Col & lRow)
            If PartialString = False Then
                .AutoFilter Field:=1, Criteria1:=SearchString
            Else
                .AutoFilter Field:=1, Criteria1:="=*" & SearchString & "*"
            End If
            
            Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
        End With

        '~~> Remove any filters
        .AutoFilterMode = False
    End With
    
    '~~> Some sheet where you want to paste the output
    Dim SomeSheet As Worksheet
    Set SomeSheet = ThisWorkbook.Sheets("Output")
    
    If Not copyFrom Is Nothing Then
        '~~> Copy and paste to some sheet
        copyFrom.Copy SomeSheet.Rows(1)
        
        'After copying, delete the unwanted columns (OPTIONAL)
    End If
End Sub

This code manages to find a match, but just for the first found row on the "Specifications" table. It should continue looking even after it finds a match and look for the next match. Also it doesn't do anything with the rows that don't have a match. Those rows should also be copied into the table on "Output" in the format I explained before.

I hope I have articulated my problem enough. Thanks!

question from:https://stackoverflow.com/questions/65937214/based-on-matching-variables-in-different-tables-copy-and-paste-information

Answer 1

Waitting for answers