Hello.
I have written the below code and it works to create the the correct name and place that value in a Word doc Content Control and then add to the 2 tables the correct information.
My problem is that it is also adding other lines instead of just the code that matches the column 6 code.
There should be 4 individuals with no matches, 2 matches grouped with 4037424 and 7 matches with 4036202.
Here is the code:
Help!
I have written the below code and it works to create the the correct name and place that value in a Word doc Content Control and then add to the 2 tables the correct information.
My problem is that it is also adding other lines instead of just the code that matches the column 6 code.
There should be 4 individuals with no matches, 2 matches grouped with 4037424 and 7 matches with 4036202.
Here is the code:
Code:
Sub Mud()
Dim wordApp As Word.Application
Dim wDoc As Word.Document
Dim RPs As Worksheet
Dim LRow As Long, bug As Variant
Dim i As Variant
Dim nob As Variant
Dim First As Word.Table
Dim Second As Word.Table
'used by/for dictionary
Dim lr As Long, X As Long
Dim dic As Object
Dim arr As Variant, key As Variant
'load dictionary with Uniques From Column D
With Sheets("Released Product")
lr = .Range("F" & .Rows.Count).End(xlUp).Row
arr = .Range("F2:F" & lr)
End With
Set dic = CreateObject("Scripting.Dictionary")
For X = 1 To UBound(arr, 1)
dic(arr(X, 1)) = 1
Next X
Application.ScreenUpdating = False
LRow = Sheets("Released Product").Cells(Rows.Count, "A").End(xlUp).Row 'Sterile PO #
' bug = RPSort 'Batch/Lot #
i = LRow
Doc_Land = "C:\Location\"
Set RPs = ThisWorkbook.Sheets("Released Product")
Set wordApp = CreateObject("Word.Application")
Set wDoc = wordApp.Documents.Open(Doc_Land & RPs.Range("P31") & ".docx") '"\" & , , False
wordApp.Visible = True
Set First = wDoc.Tables(1)
Set Second = wDoc.Tables(2)
For Each key In dic.keys
For i = 3 To LRow 'To 1 Step -1 'work from the bottom up
If RPs.Cells(i, 6).Value = key And RPs.Cells(i, 1).Value = RPs.Range("O1") Then
wDoc.Activate
wDoc.ContentControls(1).Range.Text = RPs.Cells(i, 6).Value 'Sterile PO#
'1st Form
First.Rows.Add
First.Cell(First.Rows.Count, 1).Range.Text = RPs.Cells(i, 9).Value 'Sterile Prod Name
First.Cell(First.Rows.Count, 2).Range.Text = RPs.Cells(i, 8).Value 'Sterile Part #
First.Cell(First.Rows.Count, 3).Range.Text = RPs.Cells(i, 11).Value 'Test Report #
'2nd Form
Second.Rows.Add
Second.Cell(Second.Rows.Count, 1).Range.Text = RPs.Cells(i, 8).Value 'Sterile Part #
Second.Cell(Second.Rows.Count, 2).Range.Text = RPs.Cells(i, 11).Value 'Test Report #
Second.Cell(Second.Rows.Count, 3).Range.Text = RPs.Cells(i, 4).Value 'Lot #
wDoc.SaveAs Doc_Land & "BET - " & RPs.Cells(i, 6), wdFormatPDF
Set wDoc = Nothing
Set wDoc = wordApp.Documents.Open(Doc_Land & RPs.Range("P31").Value & ".docx", , False)
End If
'Set wDoc = Nothing
'wDoc.SaveAs Doc_Land & "/" & RPs.Cells(i, 6), wdFormatDocumentDefault
' wDoc.SaveAs Doc_Land & "/" & RPs.Cells(i, 6), wdFormatPDF
'.SaveAs Doc_Land & "BET - " & RPs.Cells(i, 6), wdFormatPDF
Next i
Next key
wordApp.Documents.Open(Doc_Land & RPs.Range("P31").Value & ".docx", , False) '"\" &
MsgBox "All Forms complete!", vbCritical + vbExclamation + vbOKOnly, "BET Release 1001"
End SubHelp!
Last edited:
