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
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