Looping is killing my Excel 365 VBA code!

DThib

Active Member
Joined
Mar 19, 2010
Messages
464
Office Version
  1. 365
Platform
  1. Windows
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:
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 Sub

Help!
 
Last edited:

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
I have tweaked my code.
It now looks like this, but is still holding the word doc with the information that should clear for the next Sterile PO# to fill out the document.
It saves by the SPO and places it where it needs to. The tables are not clearing of the previous data and saved document.

I am missing something but cannot figure it out.
Code:
Sub Mud()


    Dim wordApp As Word.Application
    Dim wDoc As Word.Document
    Dim RPs As Worksheet
    Dim LRow As Long
    Dim i 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 F "Sterile PO [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=s]#s[/URL] "
    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 #


     i = LRow
    
     Doc_Land = "C:\Location"
   
     Set RPs = ThisWorkbook.Sheets("Red Prod")


     Set wordApp = CreateObject("Word.Application")
     Set wDoc = wordApp.Documents.Open(Doc_Land & RPs.Range("P31") & ".docx") 
     wordApp.Visible = True
       
      Set First = wDoc.Tables(1)
      Set Second = wDoc.Tables(2)
       
       For i = LRow To 1 Step -1    
         If RPs.Cells(i, 1).Value = RPs.Range("O1") Then
            For Each key In dic.keys
               If RPs.Cells(i, 6).Value = key 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 #
               'End If
               ElseIf Not key = RPs.Cells(i, 6).Value Then
                 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)


            Next key
         End If
       Next i
       wordApp.Documents.Close (wdDoNotSaveChanges)
       wordApp.Quit
     
      MsgBox "All Forms complete!", vbCritical + vbExclamation + vbOKOnly, "BET Release 1001"
   
End Sub

DThib
 
Upvote 0
Now it actually pulls the correct identity but only the last match for logic conditions.
I need it to add all matches to the correct tables in Word 365.
Here is my updated code.

1) I need help with copying all matches not just the last and then go to the next match.

Code:
Sub Mud()


    Dim wordApp As Word.Application
    Dim wDoc As Word.Document
    Dim RPs As Worksheet
    Dim LRow As Long
    Dim i As Variant
    Dim RPcoll As New Collection
    Dim First As Word.Table
    Dim Second As Word.Table
    Dim nob, bug As Range
    
    '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 "Lot/Batch [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=s]#s[/URL] "
    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


    LRow = Sheets("Released Product").Cells(Rows.Count, "A").End(xlUp).Row 'Sterile PO #
    i = LRow
    
     Doc_Land = "C:\Test"
   
     Set RPs = ThisWorkbook.Sheets("Released Product")
     Set bug = RPs.ListObjects("RP_Table").ListColumns("Lot/Batch Number").DataBodyRange
     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 i = LRow To 1 Step -1    ' 3 To                'work from the bottom up
         If RPs.Cells(i, 1).Value = RPs.Range("O1") Then
            For Each key In dic.keys
              If RPs.Cells(i, 6).Value = key Then
                For Each nob In bug
                  If RPs.Cells(i, 6).Value = key And RPs.Cells(i, 4).Value = nob 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 #
                  End If
                Next nob
              End If
           Next key
            wDoc.SaveAs Doc_Land & "BET " & RPs.Cells(i, 6), wdFormatPDF
            With wDoc
                currDoc = .FullName
               .Close SaveChanges:=wdDoNotSaveChanges
            End With
         End If
                 Set wDoc = wordApp.Documents.Open(Doc_Land & RPs.Range("P31").Value & ".docx", , False)
                   Set First = wDoc.Tables(1)
                   Set Second = wDoc.Tables(2)


       Next i
       wordApp.Documents.Close (wdDoNotSaveChanges)
       wordApp.Quit
     
      MsgBox "All Forms complete!", vbCritical + vbExclamation + vbOKOnly, "BET Release 1001"
   
End Sub

DThib
 
Upvote 0
The first line in Norie's reply of post 6 tells you why you're not getting assistance with this.
 
Upvote 0
Thanks NoSparks

I have answered Norie's question twice.

I do not have any merged cells in my Excel data or my word document tables I am writing to.

My data is found below:
There area few more columns, but these illustrate the layout.


Columns
A:
Date Moved
B:
Unsterile
Part #
C:
Unsterile
Material Description
D:
Lot/Batch Number
E:
Date Returned
from Sterilization
F:
Sterile Load PO#
G:
Date Left
the
Cleanroom
Released Product
11-Oct-201948-0371Unsterile DVR142345121-Aug-2019371229-Jul-2019
11-Oct-201948-0371Unsterile DVR14270495-Sep-201974248-Aug-2019
11-Oct-201948-0371Unsterile DVR143085621-Sep-2019791728-Aug-2019
11-Oct-201948-3104Gen 3, non-sterile140933817-Jul-2019620225-Jun-2019
11-Oct-201948-3104Gen 3, non-sterile140936517-Jul-2019620225-Jun-2019
11-Oct-201948-3104Gen 3, non-sterile140937217-Jul-2019620225-Jun-2019
11-Oct-201948-3104Gen 3, non-sterile141244317-Jul-2019202425-Jun-2019
11-Oct-201948-3104Gen 3, non-sterile141264717-Jul-2019202425-Jun-2019
11-Oct-201948-3104Gen 3, non-sterile141265217-Jul-2019403625-Jun-2019
11-Oct-201948-3104Gen 3, non-sterile141266117-Jul-2019403625-Jun-2019
11-Oct-201943-0000-JPPurge Cassette14289045-Sep-2019403716-Aug-2019
11-Oct-201948-3109-JPPre-Sterile, Japan142417514-Aug-2019696524-Jul-2019

<colgroup><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>



DThib
 
Upvote 0
Copied that to a sheet, copied the macro to a module and can't get past the first Dim statement so I'm out.
 
Upvote 0
I had to add the reference for Microsoft Word 16.o Object Library

It allows the word code to run in excel.
That might be part of your hangup
 
Upvote 0
range("P31") ??
range("O1") ??
wDoc.Tables(1) ??
wDoc.Tables(2) ??


Good luck with your project.
 
Upvote 0
My code does create the appropriate word docs and fills the the 2 tables on the word doc. It saves and reopens a new temporary doc but closes after one match for one Sterile PO(should be 3 with set I put together.

It reopens but copies over the content or saves over the last time it was filled. So I end with the last match for all SPOs instead of the three that should match in one document.
 
Upvote 0

Forum statistics

Threads
1,213,554
Messages
6,114,280
Members
448,562
Latest member
Flashbond

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top