Code Works But Does Not Loop Through All Files

[bianca88]

Hello,

Description of the code:
This VBA code copies the formatting from specific cells in an Excel worksheet as an image and pastes it into a Word document. Specifically, the code checks if the value in column C equals 1 and opens the corresponding Word document located on my desktop as identified in column A. It then copies the content in column B of the current row, pastes it into the Word document as an image, and saves and closes the Word document.

Problem:
I currently have 78 Word documents this needs to be applied to. While the code works, it only copies and pastes the image to the first 10-15 Word documents, leaving the rest untouched. Is it that the code runs so fast that the processing cannot keep up?

For what it's worth, I was watching a lecture series on VBA code ran in Excel to automate various Outlook tasks. One task was to move all emails from one folder to another. There were approximately 15 emails, and when the code ran, it only copied about 5 of the 15 emails. To correct the issue, the instructor used the following:

For Each omail in FOL.Application.ActiveExplorer.Selection

'code here

Next omail

Perhaps there is something similar that can be applied for my use? Or perhaps run the code on the first 5 files, reset to the next 5 files, and continue in this manner until all 78 files have completed? I appreciate any help in advance.

Sub Copy()



Application.ScreenUpdating = False



Dim wdApp As Object

Dim wdDoc As Object

Dim wdRange As Object

Dim strFileName As String

Dim strFolderPath As String

Dim strValue As String

Dim i As Long



On Error Resume Next



'set the folder path and Word app object

strFolderPath = "FILE PATH GOES HERE"

Set wdApp = CreateObject("Word.application")



'loop through each row in column B

For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row

'get file name from column A , value from column B, and value from column C

strFileName = Cells(i, "A").Value

strValue = Cells(i, "B").Value

intval = Cells(i, "C").Value



'check if the value in column C equals 1

If intval = 1 Then



'open word doc

Set wdDoc = wdApp.documents.Open(strFolderPath & strFileName)

'set range to end of document

Set wdRange = wdDoc.Content

wdRange.collapse Direction:=wdCollapseEnd



'copy cell range formatting from Excel

Cells(i, "B").Copy

'paste formatting into Word and insert value from column B

wdApp.Selection.PasteSpecial DataType:=wdpastemetafilepicture

wdApp.Selection.ShapeRange.IncrementLeft 548.25

wdApp.Selection.ShapeRange.IncrementTop 30



'save and close

wdDoc.Save

wdDoc.Close

End If

Next i



'Quit word

wdApp.Quit



Set wdApp = Nothing

Application.CutCopyMode = False

Application.ScreenUpdating = False



Application.Speech.Speak "The transfer is complete."





End Sub

 

[Micron]

One way to know if slowing down the code is a solution, step through it and see if all test items are processed (whatever they are). If successful, a possible solution is to introduce a delay between loop iterations by calling a pause/timer function, set to whatever pause works. Could be as little as 0.5 seconds, maybe 1.0, maybe more. It adds to processing time, but better to click a button and go for coffee than trying to fix what ran faster but didn't work as expected. Here's a pause function I wrote for Access - should work for Excel but untested by me. Similar versions can be found on internet, but they use integer values, whereas this one will accept fractions of a second. You'd call it like Pause 1.5

Sub pause(sngSecs As Single)
Dim endTime As Long

endTime = Timer
Do Until Timer > endTime + sngSecs
Loop

End Sub

If Timer isn't available in Excel, surely something else would work.

 

[bianca88]

One way to know if slowing down the code is a solution, step through it and see if all test items are processed (whatever they are). If successful, a possible solution is to introduce a delay between loop iterations by calling a pause/timer function, set to whatever pause works. Could be as little as 0.5 seconds, maybe 1.0, maybe more. It adds to processing time, but better to click a button and go for coffee than trying to fix what ran faster but didn't work as expected. Here's a pause function I wrote for Access - should work for Excel but untested by me. Similar versions can be found on internet, but they use integer values, whereas this one will accept fractions of a second. You'd call it like Pause 1.5

Sub pause(sngSecs As Single)
Dim endTime As Long

endTime = Timer
Do Until Timer > endTime + sngSecs
Loop

End Sub

If Timer isn't available in Excel, surely something else would work.

This is fantastic! Thank you so much! I was not familiar with this code so I did some additional research. I found the following, which is very similar to yours and works great:

Sub pause(ByVal seconds As Single)    
Dim endTime As Long 
   
endTime = Timer + seconds    
Do While Timer < endTime        
DoEvents    
Loop 

End Sub

Additionally, within my code, just before the loop ends, I added pause 4. I found that 2 wasn't enough, and 5 was not necessary.

Again, thanks so much!

 

[Micron]

Glad I could help, & thanks for the recognition.