Excel not responding when running this piece of code? What am i missing?

M

mageeg

Board Regular
Joined
Jun 6, 2021
Messages
81
Hi, I have a user entry form in excel which users fill out and then data is inputted into a database. Sheet name "Database"

I then have written a piece of code to transfer data from a database to a template i have on word through the use of bookmarks.

Basically, i want the user to enter a works order number (as it is unique) into cell "D26" and then it will take this row of data from the excel database and transfer it to word.

However running this code, crashes excel.

VBA Code: 
Dim wd As Object 'Word Application
Dim wdDOC As Object 'word document
Dim iRow As Long 'Variable to hold the starting row and loop through all records in database
Dim PercentageScore As Variant 'Variable to hold percentage score
Dim sh As Worksheet 'worksheet variable to refer  to where database is stored
Dim myValue As Variant
Dim WorksOrder As String


'Start word as new document

Set wd = CreateObject("Word.Application")

'Get user entered WorksOrder Number

WorksOrder = ThisWorkbook.Sheets("Database").Range("D26").Value

'Set worksheet

Set sh = ThisWorkbook.Sheets("Database")

iRow = 2 'row in which data starts from in database


Do While sh.Range("A" & iRow).Value <> "" 'loop through until no data is found (last row of database)
 
 If WorksOrder = sh.Range("D" & iRow).Value Then

'opening word template

Set wdDOC = wd.Documents.Add("T:\mageeg\TEST DATA  INSPECTION SCHEDULE Issue 3.docx")

wd.Visible = False

'code to insert values from database to bookmarks in word

wd.Selection.GoTo what:=wdGoToBookmark, Name:="PartNo"
wd.Selection.TypeText Text:=sh.Range("C" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="Serial"
wd.Selection.TypeText Text:=sh.Range("E" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="ModelNo"
wd.Selection.TypeText Text:=sh.Range("B" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="WorksOrderNo"
wd.Selection.TypeText Text:=sh.Range("D" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="MaterialNo"
wd.Selection.TypeText Text:=sh.Range("F" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="SerialNo"
wd.Selection.TypeText Text:=sh.Range("E" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="ModelNo2"
wd.Selection.TypeText Text:=sh.Range("B" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="Type"
wd.Selection.TypeText Text:=sh.Range("H" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="Size"
wd.Selection.TypeText Text:=sh.Range("I" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="WKPRESS"
wd.Selection.TypeText Text:=sh.Range("J" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="SerialNumber"
wd.Selection.TypeText Text:=sh.Range("G" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="CertDate"
wd.Selection.TypeText Text:=sh.Range("K" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="BatchNo"
wd.Selection.TypeText Text:=sh.Range("L" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="JobNo"
wd.Selection.TypeText Text:=sh.Range("M" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="DateOfManufacture"
wd.Selection.TypeText Text:=Format(sh.Range("N" & iRow).Value, "mmm-yy")


'code to delete the existing bookmarks from wordfile

On Error Resume Next

wdDOC.Bookmarks("PartNo").Delete
wdDOC.Bookmarks("SerialNo").Delete
wdDOC.Bookmarks("ModelNo").Delete
wdDOC.Bookmarks("WorksOrderNo").Delete
wdDOC.Bookmarks("MaterialNo").Delete
wdDOC.Bookmarks("Serial").Delete
wdDOC.Bookmarks("ModelNo2").Delete
wdDOC.Bookmarks("Type").Delete
wdDOC.Bookmarks("Size").Delete
wdDOC.Bookmarks("WKPRESS").Delete
wdDOC.Bookmarks("SerialNumber").Delete
wdDOC.Bookmarks("CertDate").Delete
wdDOC.Bookmarks("BatchNo").Delete
wdDOC.Bookmarks("JobNo").Delete
wdDOC.Bookmarks("DateOfManufacture").Delete

'save file with new name

wdDOC.SaveAs2 (ThisWorkbook.Path & "\" & sh.Range("D" & iRow).Value & ".docx")

'Print document


'close the word file

wdDOC.Close

'release memory of word doc

Set wdDOC = Nothing

iRow = iRow + 1

Exit Do

End If


Loop

wd.Quit 'close MS Word

Set wd = Nothing 'Release memory allocated to WD

MsgBox ("Inspection Test Sheet Created")

End Sub
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
Sort by date Sort by votes
*NOTE*

Found out that if i remove the following lines, it runs:

VBA Code: 
WorksOrder = ThisWorkbook.Sheets("Database").Range("D26").Value
If WorksOrder = sh.Range("D" & iRow).Value The

However then this doesnt do what i want, as it runs through everyline of the database and transfers it, but i want it to transfer just the line dependent on the WorksOrder number entered by the user
 
Upvote 0
mageeg said:
Hi, I have a user entry form in excel which users fill out and then data is inputted into a database. Sheet name "Database"

I then have written a piece of code to transfer data from a database to a template i have on word through the use of bookmarks.

Basically, i want the user to enter a works order number (as it is unique) into cell "D26" and then it will take this row of data from the excel database and transfer it to word.

However running this code, crashes excel.

VBA Code: 
Dim wd As Object 'Word Application
Dim wdDOC As Object 'word document
Dim iRow As Long 'Variable to hold the starting row and loop through all records in database
Dim PercentageScore As Variant 'Variable to hold percentage score
Dim sh As Worksheet 'worksheet variable to refer  to where database is stored
Dim myValue As Variant
Dim WorksOrder As String


'Start word as new document

Set wd = CreateObject("Word.Application")

'Get user entered WorksOrder Number

WorksOrder = ThisWorkbook.Sheets("Database").Range("D26").Value

'Set worksheet

Set sh = ThisWorkbook.Sheets("Database")

iRow = 2 'row in which data starts from in database


Do While sh.Range("A" & iRow).Value <> "" 'loop through until no data is found (last row of database)
 
 If WorksOrder = sh.Range("D" & iRow).Value Then

'opening word template

Set wdDOC = wd.Documents.Add("T:\mageeg\TEST DATA  INSPECTION SCHEDULE Issue 3.docx")

wd.Visible = False

'code to insert values from database to bookmarks in word

wd.Selection.GoTo what:=wdGoToBookmark, Name:="PartNo"
wd.Selection.TypeText Text:=sh.Range("C" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="Serial"
wd.Selection.TypeText Text:=sh.Range("E" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="ModelNo"
wd.Selection.TypeText Text:=sh.Range("B" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="WorksOrderNo"
wd.Selection.TypeText Text:=sh.Range("D" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="MaterialNo"
wd.Selection.TypeText Text:=sh.Range("F" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="SerialNo"
wd.Selection.TypeText Text:=sh.Range("E" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="ModelNo2"
wd.Selection.TypeText Text:=sh.Range("B" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="Type"
wd.Selection.TypeText Text:=sh.Range("H" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="Size"
wd.Selection.TypeText Text:=sh.Range("I" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="WKPRESS"
wd.Selection.TypeText Text:=sh.Range("J" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="SerialNumber"
wd.Selection.TypeText Text:=sh.Range("G" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="CertDate"
wd.Selection.TypeText Text:=sh.Range("K" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="BatchNo"
wd.Selection.TypeText Text:=sh.Range("L" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="JobNo"
wd.Selection.TypeText Text:=sh.Range("M" & iRow).Value

wd.Selection.GoTo what:=wdGoToBookmark, Name:="DateOfManufacture"
wd.Selection.TypeText Text:=Format(sh.Range("N" & iRow).Value, "mmm-yy")


'code to delete the existing bookmarks from wordfile

On Error Resume Next

wdDOC.Bookmarks("PartNo").Delete
wdDOC.Bookmarks("SerialNo").Delete
wdDOC.Bookmarks("ModelNo").Delete
wdDOC.Bookmarks("WorksOrderNo").Delete
wdDOC.Bookmarks("MaterialNo").Delete
wdDOC.Bookmarks("Serial").Delete
wdDOC.Bookmarks("ModelNo2").Delete
wdDOC.Bookmarks("Type").Delete
wdDOC.Bookmarks("Size").Delete
wdDOC.Bookmarks("WKPRESS").Delete
wdDOC.Bookmarks("SerialNumber").Delete
wdDOC.Bookmarks("CertDate").Delete
wdDOC.Bookmarks("BatchNo").Delete
wdDOC.Bookmarks("JobNo").Delete
wdDOC.Bookmarks("DateOfManufacture").Delete

'save file with new name

wdDOC.SaveAs2 (ThisWorkbook.Path & "\" & sh.Range("D" & iRow).Value & ".docx")

'Print document


'close the word file

wdDOC.Close

'release memory of word doc

Set wdDOC = Nothing

iRow = iRow + 1

Exit Do

End If


Loop

wd.Quit 'close MS Word

Set wd = Nothing 'Release memory allocated to WD

MsgBox ("Inspection Test Sheet Created")

End Sub
Click to expand...

NOTE!! I have found more info, it is only crashing if the WorksOrder number written in Cell "D26" is not in the first row of the database. If the WorksOrder number written in row 1 is written, it works
 
Upvote 0
Please note: Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: Excel Crashing When Running This Code? (Transfer of Data from Excel To Word)
If you have posted the question at more places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.
 
Upvote 0
Your code only increments iRow if the value is found. Otherwise it simply checks the same row over and over again.
 
Upvote 0
Solution
RoryA said:
Your code only increments iRow if the value is found. Otherwise it simply checks the same row over and over again.
Click to expand...
Hi Rory, thanks for getting back to me!

Sorry for not doing the cross-posting correctly, didn't know there was a rule for that! Will know this now for the future.

As for the code, Ah okay i see what you mean!

Would you be able to help me edit my code to stop this from happening?
 
Upvote 0
Just move the iRow = iRow + 1 line after the End If.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Run Macro for only selected row
Replies
2
Views
479
Suavesav
S
M
  • Solved
Where to put the Else MsgBox in my code?
Replies
3
Views
651
mageeg
M
B
  • Question Question
Automatically filling a label template in Excel
Replies
0
Views
2K
Ben171
B
M
  • Question Question
Specifying Printer in this scenario
Replies
0
Views
1K
mageeg
M
F
  • Question Question
Excel Data to Word Template
2
Replies
10
Views
2K
NdNoviceHlp
NdNoviceHlp

Forum statistics

Threads
1,223,236
Messages
6,170,917
Members
452,366
Latest member
TePunaBloke

Share this page

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