Looping is killing my Excel 365 VBA code!

DThib

Active Member
Joined
Mar 19, 2010
Messages
429
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:

DThib

Active Member
Joined
Mar 19, 2010
Messages
429
I now get all instances of the matching PO being accounted for in each document, but they only show the last records results for all entries.
The macro gives me the appropriate docs with Sterile PO #s showing up as the title and the content control.
I need to have the rows with today’s date matching date (current results that match logic tests.
The cell (O1) is the current date
I am posting the table data it draws from below.
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
    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("D" & .Rows.Count).End(xlUp).Row
          arr = .Range("D2:D" & 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:\Test"
   
     Set RPs = ThisWorkbook.Sheets("Released Product")
     Set bug = RPs.ListObjects("RP_Table").ListColumns("Sterile Load PO#").DataBodyRange 'Sterile Load PO#  Lot/Batch Number
     Set wordApp = CreateObject("Word.Application")
     Set wDoc = wordApp.Documents.Open(Doc_Land & "P31-" & ".docx")
      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, 4).Value = key Then
                   If RPs.Cells(i, 6).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
                 End If
                    'wDoc.SaveAs Doc_Land & "Beft" & RPs.Cells(i, 6), wdFormatPDF
               Next nob
                   wDoc.SaveAs Doc_Land &  "Beft" &  RPs.Cells(i, 6), wdFormatPDF
           Next key
                     currDoc = wDoc.FullName
                     wDoc.Close SaveChanges:=wdDoNotSaveChanges


                  Set wDoc = wordApp.Documents.Open(Doc_Land & "QR-2345" & ".docx")
                  Set First = wDoc.Tables(1)
                  Set Second = wDoc.Tables(2)


         End If
             
            'wDoc.SaveAs Doc_Land & "Beft " & RPs.Cells(i, 6), wdFormatDocumentDefault


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

Here is the table: I used 13-Oct-2016 for date
Date MovedUnsterile
Part #
Unsterile
Material Description
Lot/Batch
Number
Date Returned
from Sterilization
Sterile Load PO#Date Left
the
Cleanroom
Sterile Part #Sterile Material Descriptionwk #Test Reports for Endotoxin
9-Oct-20190048-0371Pump , Unsterile85621-Sep-2019791728-Aug-20190048-3092PUMP, STERILE3923453
13-Oct-20190048-0371Pump , Unsterile45121-Aug-2019712029-Jul-20190048-3092PUMP, STERILE34R-19-005
13-Oct-20190048-0371Pump , Unsterile0495-Sep-201974248-Aug-20190048-3092PUMP, STERILE36R-19-000
9-Oct-20190048-0371Pump, Unsterile0515-Sep-201947248-Aug-20190048-3092PUMP, STERILE36R-19-000
9-Oct-20190048-0371Pump, Unsterile85621-Sep-2019791728-Aug-20190048-3092PUMP, STERILE3944541
13-Oct-20190048-3104GWRU Gen 3, non-sterile33817-Jul-2019620225-Jun-20190048-3105GWRU Gen 3, sterile29R-19-0544
13-Oct-20190048-3104 GWRU Gen 3, non-sterile36517-Jul-2019620225-Jun-20190048-3105GWRU Gen 3, sterile29R-19-0544
9-Oct-20190048-3104 GWRU Gen 3, non-sterile37217-Jul-2019620225-Jun-20190048-3105GWRU Gen 3, sterile29R-19-0544
9-Oct-20190048-3104GWRU Gen 3, non-sterile44317-Jul-2019620225-Jun-20190048-3105GWRU Gen 3, sterile29R-19-0544
9-Oct-20190048-3104WRU Gen 3, non-sterile64717-Jul-2019620225-Jun-20190048-3105GWRU Gen 3, sterile29R-19-0544
9-Oct-20190048-3104GWRU Gen 3, non-sterile65217-Jul-2019620225-Jun-20190048-3105GWRU Gen 3, sterile29R-19-0544
9-Oct-20190048-3104GWRU Gen 3, non-sterile66117-Jul-2019620225-Jun-20190048-3105GWRU Gen 3, sterile29R-19-0544
9-Oct-20190043-0000-JPPurge, non-sterile, Japan9045-Sep-2019762216-Aug-20190048-3001-JPPurge, Sterile, Japan3644552

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


DThib
 

Some videos you may like

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.

DThib

Active Member
Joined
Mar 19, 2010
Messages
429
Can anyone help me figure out why my code is showing the correct values but it is carrying the previous results into the new document?

I get all the correct responses but the first document's results are maintained and the second is appended to the bottom of the list.

There is some code I am missing....

DThib
 

DThib

Active Member
Joined
Mar 19, 2010
Messages
429

ADVERTISEMENT

The Latest results are (Drum roll, please.:

The following code is placing the results as requested, but the word doc saved as a pdf is not releasing the memory and thus results are being opened and filled in the Word doc version and then saved to the pdf form that is holding the last P.O. results.
The code is the same as posted last the part I am talking about is below.

Code:
               Next Nob
                  wDoc.SaveAs2 Liza_Land & "BET " & RPs.Cells(i, 7), wdFormatPDF
                  Set wDoc = Nothing
I was hoping that setting the object (wDoc) to nothing would release the pdf document memory, but is not working.

DThib
 

NoSparks

Well-known Member
Joined
Mar 15, 2013
Messages
1,051
Office Version
  1. 2010
Platform
  1. Windows

ADVERTISEMENT

Can you tell me if anyone is able to run/test your macro without your docx file ?
 

NoSparks

Well-known Member
Joined
Mar 15, 2013
Messages
1,051
Office Version
  1. 2010
Platform
  1. Windows
Try this
Code:
Sub Mud_v21()
' use against data from post 21
' https://www.mrexcel.com/forum/excel-questions/1111944-looping-killing-my-excel-365-vba-code.html

    Dim wordApp As Word.Application, wDoc As Word.Document
    Dim First As Word.Table, Second As Word.Table
    Dim RPs As Worksheet, i As Long
    Dim Doc_Land As String
    Dim additionalRows As Boolean
    'used by/for dictionary
    Dim lr As Long, X As Long
    Dim dic As Object
    Dim arr As Variant, key As Variant

    Set RPs = ThisWorkbook.Sheets("Released Product")
    
    'load dictionary with Uniques From Column F "Sterile Load PO#"
    With RPs
      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
    
    Doc_Land = "D:\Test\"   '<<<<<<<<<< changed to suit
   
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = True

    For Each key In dic.keys
        additionalRows = False
        Set wDoc = wordApp.Documents.Open(Doc_Land & "F01 rB(draft)" & ".docx")
        Set First = wDoc.Tables(1)
        Set Second = wDoc.Tables(2)
       
        For i = lr 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").Value Then
                 wDoc.Activate
                 wDoc.ContentControls(1).Range.Text = key            '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 #
                'rows added ?
                additionalRows = True
            End If
        Next i
        
        'save wdoc as pdf
        If additionalRows = True Then
            wDoc.SaveAs Doc_Land & "Beft" & key, wdFormatPDF
        End If
        'close wdoc without saving
        wDoc.Close SaveChanges:=wdDoNotSaveChanges
    Next key
    
    'quit Word
    wordApp.Quit
    
    MsgBox "All Forms complete!", vbCritical + vbExclamation + vbOKOnly, "BET Release 1001"
   
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,128,054
Messages
5,628,335
Members
416,311
Latest member
S991102

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
Top