Extract rows of data with partial match in a column from one sheet then populates 2nd sheet with matching row data

I have been trying to get this to work for a good part of a week, but am limited in my knowledge of VBA syntax so nothing I've been able to find has worked. Please help.

I have 4 workbooks. "Template", "Process", "CR" and "DQM" each having one sheet named the same as the workbook (except the Template one). The "Template" workbook is my destination workbook with the other 3 being source workbooks with variable row and column data. I have code in "Template" that loops through the data in "Process" and creates a "NewSheet" in "Template" for each value in "IDColumn" in "Process" and names the sheet with that value and populates some data on the "New Sheet". Works beautiful.

Within the loop "i" that creates the sheets, I need to extract only rows from the "CR" workbook, where the "SORID" column contains (partial text) that matches the value for the "NewSheet" in the "Template" workbook. The value I need to match on also gets populated on each "NewSheet" in cell "B4". All matching rows in the "CR" source workbook should then get populated on rows on the matching "NewSheet" starting in cell "E5". I do not want it to copy/paste, just populate the data. (Note: I have populated other data with out copy/paste by using code similar to: WB1.WS1.Range.Value = WB2.WS2.RAnge.Value so I know it can be done and it is very fast.)

Once that is done, I need to do the same thing with the "DQM" workbook data as I did with the "CR" data, but it should populate 5 rows down from the last row of "CR" data, still starting in Column E. I will also need to create a header for the DQM data that is 3 rows done from the last row of the CR data and will populate column headers on row beneath DQM Header. One difference is i don't need to populate columns A and B in the destination worksheets, so extracting only part of each matching row.

CR Source Data enter image description here

DQM Source Data enter image description here

Template Final Result Sheet 123456: enter image description here Sheet 234567: enter image description here Sheet 345678: enter image description here

I have spreadsheets I can attach if someone can direct me how to do it.

I have tried variations using "InStr" and ".value=.value" type of code. I have found bits and pieces of how to accomplish this, but am not experienced enough to tweak it to make it work for me and most were using a copy/paste scenario which I definitely do not want.

Please add comments to lines of code so I know what it is doing so I can learn. Thank you very much for any assistance!

CR Data:

CR#	SORID	Title	Type	Current	Proposed	Submitted	Submission ID	Status	Notes
123	123456	Sample	Metadata	Yes	No	6/4/24	E734	Jira	Notes
124	123456, 678912	Sample	Model	No	Yes	6/4/24	E736	Jira	Notes
256	123456	Sample	Owner	Really long text	Really long text too	6/4/24	E736	Jira	Notes
6789	234567	Sample	Metadata	Yes	No	6/4/24	RTIM695	Jira	Notes
9214	123456, 234567, 456789	Sample	Model	Yes	No	6/4/24	123_CCCC	RSM	Notes

DQM Data:

iGrafx ID	Process Name	Date	Open	Name	Type	Element
345678	Name for 345678	4/1/24	70	Sample Text	Completeness	Owner
123456	Sample Name	2/6/22	425	Sample Text	Completeness	Applications
123456	Sample Name	6/1/24	10	Another sample	Accuracy	Work Products
345678	Name for 345678	3/9/23	360	Sample Text	Completeness	Applications
345678	Name for 345678	4/10/24	60	Another sample	Accuracy	Work Products

Template Destination File:

Data on	sheet "123456"

	Current Data	CR Header
iGrafx ID	123456	CR#	SORID	Title	Type	Current	Proposed	Submitted	Submission ID	Status	Notes
Owner	Mary Smith	123	123456	Sample	Metadata	Yes	No	6/4/24	E734	Jira	Notes
Summary	Sample data for illistrative purposes.	124	123456, 678912	Sample	Model	No	Yes	6/4/24	E736	Jira	Notes
		256	123456	Sample	Owner	Really long text	Really long text too	6/4/24	E736	Jira	Notes


		DQM Header
		Date	Open	Name	Type	Element
		2/6/22	425	Sample Text	Completeness	Applications
		6/1/24	10	Another sample	Accuracy	Work Products

Code:

Sub Fill_Data_ProcessAttestation()

Everything from here to line 35 works fabulously

Dim AlignedProcesses As Worksheet  
Dim NewSheet As Worksheet  
Dim AttestTemplate As Workbook  
Dim lastRow As Long  
Dim i As Long  
Dim IDColumn  

Set AttestTemplate = ActiveWorkbook 'Template xlsm workbook/file

Set AlignedProcesses = Workbooks("Aligned Processes_data.csv").Sheets("Aligned Processes_Data")

IDColumn = 1 'Column to get the unique iGrafx IDs to create tabs

lastRow = AlignedProcesses.Cells(AlignedProcesses.Rows.Count, IDColumn).End(xlUp).Row

For i = 2 To lastRow
With AttestTemplate
    Set NewSheet = .Worksheets.Add(After:=.Worksheets("RAU Information"))
End With

TabName = AlignedProcesses.Cells(i, IDColumn)
NewSheet.Name = TabName

NewSheet.Cells(1, 1).Value = "Details, DQM and Changes"
With NewSheet.Range("A1:N1")
    .MergeCells = True
End With

NewSheet.Cells(3, 2).Value = "Current Details"
NewSheet.Cells(3, 3).Value = "Proposed Changes"

NewSheet.Range("A4:A29").Value = WorksheetFunction.Transpose(Workbooks("Aligned Processes_data.csv").Sheets("Aligned Processes_data").Range("A1:Z1").Value)
NewSheet.Range("B4:B29").Value = WorksheetFunction.Transpose(Workbooks("Aligned Processes_data.csv").Sheets("Aligned Processes_data").Range(AlignedProcesses.Cells(i, IDColumn), AlignedProcesses.Cells(i, IDColumn + 25)).Value)

Here's the code that I"m having issues with. From here to the end of the "d" loop. I have commented where things are working properly.

    Dim OpenCRs As Worksheet  
    Dim CRSourcelastRow As Long  
    Dim CRDestLastRow As Long  
    Dim SORIDColumn  
    Dim CRIDColumn  
    Dim c As Long  
    
    SORIDColumn = 3
    CRIDColun = 1
    
    'These next 2 lines work fine-no issue
    Set OpenCRs = Workbooks("CR.csv").Sheets("CR")
    NewSheet.Cells(3, 5).Value = "Open Change Requests"
    
    CRSourcelastRow = OpenCRs.Cells(OpenCRs.Rows.Count, SORIDColumn).End(xlUp).Row 'Find last row on CR csv source file
    CRDestLastRow = NewSheet.Cells(NewSheet.Rows.Count, "E").End(xlUp).Row 'Find last row of CR data on relative sheet in destination file "Template"
    
    NewSheet.Range("E4:N4").Value = Workbooks("CR.csv").Sheets("CR").Range("A1:J1").Value  'Works fine
    
    On Error Resume Next

This "For" loop should find all rows in the source CSV file where the SORIDColumn contains the value that is the tab/sheet name created in the "i" loop. Then It should write those rows to the "Template" file starting in column E, row 5.

    For c = 2 To CRSourcelastRow
        If InStr(Workbooks("CR.csv").Sheets("CR").Cells(c, SORIDColumn).Value, TabName) Then
            NewSheet.Cells(CRDestLastRow + 1, 5).End(xlToRight).Value = OpenCRs.Range(c, CRIDColumn).End(xlToRight).Value
        End If
    Next c

    
    Dim DQM As Worksheet
    Dim d As Long
    Dim DQMSourceLastRow As Long
    Dim DQMDestLastRow As Long
    Dim iGrafxIDColumn
    iGrafxIDColumn = 1
    
    Set DQM = Workbooks("DQM.csv").Sheets("DQM")
    NewSheet.Cells(CRTblLastRow + 3, 5).Value = "DQM Anomalies" 'Works fine
    
    DQMSourceLastRow = DQM.Cells(DQM.Rows.Count, iGrafxIDColumn).End(xlUp).Row 'Find last row on DQM csv source file
    DQMDestLastRow = NewSheet.Cells(NewSheet.Rows.Count, CRDestLastRow + 5).End(xlUp).Row 'Find last row of DQM data on relative sheet in destination file "Template"
    
    NewSheet.Range(CRDestLastRow + 4, 5).End(xlToRight).Value = Workbooks("DQM.csv").Sheets("DQM").Range("C1:I1").Value
    
    On Error Resume Next

This "For" loop should find all rows in the source CSV file where the iGrafxIDColumn contains the value that is the tab/sheet name created in the "i" loop. Then It should write those rows to the "Template" file starting in column E, 5 rows below the last row in the CR data range (loop "c").

    For d = 2 To DQMSourceLastRow
        If InStr(Workbooks("DQM.csv").Sheets("DQM").Cells(d, iGrafxIDColumn).Value, TabName) Then
            NewSheet.Range(DQMDestLastRow + 1, 5).End(xlToRight).Value = DQM.Range(d, iGrafxIDColumn).End(xlToRight).Value
        End If
    Next d

Next i

End Sub

Solution

Untested but this should be close:

Option Explicit

Sub Fill_Data_ProcessAttestation()
    'use constants for fixed values
    Const ID_COL_PROC As Long = 1
    Const ID_COL_SOR As Long = 3
    Const ID_COL_CR As Long = 2
    Const ID_COL_GRAFX As Long = 1
    
    Dim AlignedProcesses As Worksheet, wsAPD As Worksheet
    Dim NewSheet As Worksheet, OpenCRs As Worksheet, TabName
    Dim AttestTemplate As Workbook, DQM As Worksheet
    Dim lastrow As Long, i As Long, lastePasteRow As Long
    
    Set AttestTemplate = ActiveWorkbook 'Template xlsm workbook/file  ? ThisWorkbook ?
    
    Set AlignedProcesses = Workbooks("Aligned Processes_data.csv").Sheets("Aligned Processes_Data")
    lastrow = LastValueRow(AlignedProcesses, ID_COL_PROC)
    
    For i = 2 To lastrow
    
        TabName = AlignedProcesses.Cells(i, ID_COL_PROC)
        Set NewSheet = AttestTemplate.Worksheets.Add( _
                   After:=AttestTemplate.Worksheets("RAU Information"))
        With NewSheet
            .Name = TabName
            .Cells(1, 1).Value = "Details, DQM and Changes"
            .Range("A1:N1").MergeCells = True
            .Cells(3, 2).Value = "Current Details"
            .Cells(3, 3).Value = "Proposed Changes"
            .Cells(3, 5).Value = "Open Change Requests"
            CopyValues AlignedProcesses.Range("A1:Z1"), .Range("A4"), True 'True = transpose
            CopyValues AlignedProcesses.Cells(i, "A").Resize(1, 26), _
                                                        .Range("B4"), True
        End With
        
        Set OpenCRs = Workbooks("CR.csv").Sheets("CR")
        Set DQM = Workbooks("DQM.csv").Sheets("DQM")
        
        'copy CR data and return the row number of the last-pasted row
        lastePasteRow = CopyMatchedRows(OpenCRs.Range("A1:J1"), _
                                        ID_COL_SOR, TabName, _
                                        NewSheet.Range("E4"), _
                                        "No Open CRs")
        
        NewSheet.Cells(lastePasteRow + 3, "E").Value = "DQM Anomalies"
        
        'copy DQM data and return the row number of the last-pasted row
        lastePasteRow = CopyMatchedRows(DQM.Range("C1:I1"), _
                                        ID_COL_GRAFX, TabName, _
                                        NewSheet.Cells(lastePasteRow + 5, "E"), _
                                        "No Open DQM Anomalies")
        
        Debug.Print "Last-pasted row: ", lastePasteRow
        
    Next i

End Sub

'Copy matched rows, starting with the headers(always copied)
'  Data rows are copied if the value in the column `idColNum` of that row
'  contains a match for `idValue`
'   rw:         the first row(headers) of the source table
'   idColNum:   column number of the id value(s) in each data row
'   idValue:    the id to be tested against
'   cDest:      the first paste position (single cell)
'   NoDataMsg:  message placed under the first header if no data rows were copied
Function CopyMatchedRows(rw As Range, idColNum As Long, idValue, cDest As Range, _
                                                Optional NoDataMsg As String = "") As Long
    Dim lastrow As Long, v, arr, i As Long, copiedData As Boolean
    
    lastrow = LastValueRow(rw.Worksheet, rw.Cells(idColNum).Column) 'last-used row in ID column
    
    CopyValues rw, cDest        'copy the headers
    Set rw = rw.Offset(1)       'first row of data
    copiedData = False          'default
    Do While rw.Row <= lastrow
        v = rw.EntireRow.Cells(idColNum).Value        'id value
        arr = Split(v, ",")                 'get an array of id values
        For i = LBound(arr) To UBound(arr)  'loop id column values
            If Trim(arr(i)) = Trim(idValue) Then  'id match?
                Set cDest = cDest.Offset(1) 'next paste position
                CopyValues rw, cDest        'copy the data row
                CopyMatchedRows = cDest.Row 'last paste destination
                copiedData = True           'matched at least one row
                Exit For                    'stop looping
            End If
        Next i
        Set rw = rw.Offset(1) 'next data row
    Loop
    'if no rows were copied and a message was provided, add the message
    If Not copiedData And Len(NoDataMsg) > 0 Then
        cDest.Offset(1).Value = NoDataMsg
        Set cDest = cDest.Offset(1)
    End If
    
    CopyMatchedRows = cDest.Row 'last row filled
End Function


'Return the row of the last-populated cell in column `col` (numeric or letter) on sheet `ws`
Function LastValueRow(ws As Worksheet, col As Variant) As Long
    If Not IsNumeric(col) Then col = ws.Columns(col).Column 'user passed in column letter?
    LastValueRow = ws.Cells(ws.Rows.Count, col).End(xlUp).Row
End Function

'copy values from rngSrc to rngDest, optionally transposed
Function CopyValues(rngSrc As Range, rngDest As Range, Optional Transposed As Boolean = False)
    Dim arr
    If rngSrc.Cells.Count = 1 Then
        rngDest(1).Value = rngSrc.Value
    Else
        arr = IIf(Transposed, Application.Transpose(rngSrc.Value), rngSrc.Value)
        rngDest(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    End If
End Function