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 will try it today, thanks for working on this. I follow your logic, hopefully this will do the trick.


DThib
 

Some videos you may like

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).

DThib

Active Member
Joined
Mar 19, 2010
Messages
429
It worked beautifully. Thank you!

I adjusted it slightly, but thank you for figuring out my quandary.

DThib
 

Watch MrExcel Video

Forum statistics

Threads
1,127,420
Messages
5,624,693
Members
416,040
Latest member
patriciocabello

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