Import data from an Excel file to an Access table - excel

I'm trying to import the data from an Excel file selected by the user and importing it's data into a table in access.
To ask the user to select the file I use this code
Private Function importarExcelTabla()
Dim excelMedi As Variant
Dim cuadroSeleccion As Office.FileDialog
Set cuadroSeleccion = Application.FileDialog(msoFileDialogFilePicker)
'Abre el cuadro de seleccion de ficheros
With cuadroSeleccion
.AllowMultiSelect = False
.Title = "Selecciona el archivo por favor"
.Filters.Clear
.Filters.Add "Todos los archivos", "*.*", 1
If .Show = True Then
excelMedi = cuadroSeleccion.SelectedItems(1)
Once is selected I use the transgerSpreadsheet to import the .xlsx file to the table from a range
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "MediPrueba",
excelMedi, False, "A2:L950"
End If
End With
End Function
But my problem is that the table is not filled with the excel data and also I put the range from one file but:
¿It is possible to select all the document without the first line so this will work in other excel files with others lengths?
Thank you in advance

There is in fact Check out this code from www.accessmvp.com/KDSnell/EXCEL_Import.htm
This code works by selecting a starting point (top right corner) and works until it encounters a blank row at which point it stops. To skip the first row set the starting point to A2
Dim lngColumn As Long
Dim xlx As Object, xlw As Object, xls As Object, xlc As Object
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim blnEXCEL As Boolean
blnEXCEL = False
' Establish an EXCEL application object
On Error Resume Next
Set xlx = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xlx = CreateObject("Excel.Application")
blnEXCEL = True
End If
Err.Clear
On Error GoTo 0
' Change True to False if you do not want the workbook to be
' visible when the code is running
xlx.Visible = True
' Replace C:\Filename.xls with the actual path and filename
' of the EXCEL file from which you will read the data
Set xlw = xlx.Workbooks.Open("C:\Filename.xls", , True) ' opens in read-only mode
' Replace WorksheetName with the actual name of the worksheet
' in the EXCEL file
Set xls = xlw.Worksheets("WorksheetName")
' Replace A1 with the cell reference from which the first data value
' (non-header information) is to be read
Set xlc = xls.Range("A1") ' this is the first cell that contains data
Set dbs = CurrentDb()
' Replace QueryOrTableName with the real name of the table or query
' that is to receive the data from the worksheet
Set rst = dbs.OpenRecordset("QueryOrTableName", dbOpenDynaset, dbAppendOnly)
' write data to the recordset
Do While xlc.Value <> ""
rst.AddNew
For lngColumn = 0 To rst.Fields.Count - 1
rst.Fields(lngColumn).Value = xlc.Offset(0, lngColumn).Value
Next lngColumn
rst.Update
Set xlc = xlc.Offset(1,0)
Loop
rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing
' Close the EXCEL file without saving the file, and clean up the EXCEL objects
Set xlc = Nothing
Set xls = Nothing
xlw.Close False
Set xlw = Nothing
If blnEXCEL = True Then xlx.Quit
Set xlx = Nothing

Related

Find and copying text highlighted in a specific color

Hi I have a code (see below) that is working like a charm to find and copy text from a specific style and paste it in another document. It is in an excel file because I preferred this option to share with friends that would only need to click in the button, chose the input file and save as their preferred output file name.
Now I'm trying without success to perform the same task with text highlighted in a specific color (e. Turquoise). Please find below the code that is working with a specific word or style, I made some experiences with code I found here and there, but all I could get was to copy all highlighted text instead of my choice of color. See below. Any help is much appreciated.
Note on Edit: The code below is the closer I get to the desired result. It was a little chaotic due to my try and error attempts.
' Objects
Dim wrdApp, objWord As Object
Dim wrdDoc, newwrdDoc As Object
Dim myPath As String, myPath1 As String
Dim folderPath As String
Dim myFile As String
Dim numberStart As Long
Dim Rng, srchRng As Excel.Range
'Dim objDoc As Document, objDocAdd As Document
Dim objRange As Range
Dim strFindColor As String
Dim highliteColor As Variant
Dim i As Long
' Close MS Word if it's already opened
On Error Resume Next
Set objWord = GetObject(, "Word.Application")
If Not objWord Is Nothing Then
objWord.Quit SaveChanges:=0
Set objWord = Nothing
End If
'Defining input file name
myFile = Application.GetOpenFilename()
'Open MS Word
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
' Folder Location
myPath = Application.ThisWorkbook.Path & "\"
' Input File
Set wrdDoc = wrdApp.Documents.Open(myFile)
' Output File
Set newwrdDoc = wrdApp.Documents.Add
myPath1 = Application.GetSaveAsFilename(FileFilter:="Word files(*.docx),*.docx")
' Text you want to search
'Dim FindWord As String
'Dim result As String
'FindWord = ""
highliteColor = Array(wdTurquoise)
'Style
'mystyle = wdTurquoise
'Defines selection for Word's find function
wrdDoc.SelectAllEditableRanges
' Find Functionality in MS Word
For i = LBound(wdTurquoise) To UBound(wdTurquoise)
objDoc.Activate
Selection.HomeKey Unit:=wdStory
objRange.Collapse wdCollapseEnd
With wrdDoc.ActiveWindow.Selection.Find
.HighlightColorIndex = wdTurquoise
.Highlight = True
.Forward = True
.Wrap = wdFindStop
objRange = Selection.Range
objDocAdd.Range.InsertAfter objRange & vbCr
Selection.Collapse wdCollapseEnd
End With
Next
' Execute find method
wrdDoc.ActiveWindow.Selection.Find.Execute
' Store Selected text
result = wrdDoc.ActiveWindow.Selection.Text
' Check if result contains non-blank text
If Len(result) > 1 Then
' -------------------------------------------------------------
' Loop through multiple find content (Find All functionality)
' -------------------------------------------------------------
While wrdDoc.ActiveWindow.Selection.Find.Found
wrdDoc.ActiveWindow.Selection.Copy
'Activate the new document
newwrdDoc.Activate
'New Word Doc
Set Rng = newwrdDoc.Content
Rng.Collapse Direction:=wdCollapseEnd
Rng.Paste
'Word Document
wrdDoc.Activate
wrdDoc.ActiveWindow.Selection.Find.Execute
Wend
' If style not found
Else
MsgBox "Text Not Found"
End If
'Close and don't save application
wrdDoc.Close SaveChanges:=False
'Save As New Word Document
newwrdDoc.SaveAs myPath1
newwrdDoc.Close SaveChanges:=True
'Close all word documents
wrdApp.Quit SaveChanges:=0
'Message when done
MsgBox "Task Accomplished"
End Sub

How do I close an Excel spreadsheet in VBA code?

I have the following routine below that is meant to open an Excel spreadsheet and then go row by row to import the results into a table that is passed in. It works fine but the problem is if I try to open that same spreadsheet a second time I get a message that the file is in use and I have to Ctrl-Alt-Del to shut down Excel before I can use it again. I thought that the Set mySheet=Nothing and Set xlApp=Nothing would release the file but apparently not. What more can I do to make sure that Access lets go of the Excel file? Thanks in advance!
Public Sub MakeTempTable(strFilePath As String, tablename As String)
Dim mySheet As Object
Dim xlApp As Object
Dim rs As DAO.Recordset
Dim sql As String
sql = "DELETE * FROM " & tablename
DoCmd.RunSQL sql
Set rs = CurrentDb.OpenRecordset(tablename)
Set xlApp = CreateObject("Excel.Application")
Set mySheet = xlApp.Workbooks.Open(strFilePath).Sheets(1)
xlApp.Visible = False
Set mySheet = xlApp.Sheets("Input")
Dim dRows As Double
dRows = 1
Dim dRow As Double, dCol As Double
dRow = 2
On Error GoTo ERR
Do
dCol = 1
rs.AddNew
If mySheet.cells(dRow, 3) = "" Then Exit Do
Do
If mySheet.cells(dRow, dCol).Value <> "_END_" Then
rs.Fields(dCol).Value = Nz(mySheet.cells(dRow, dCol).Value, "")
dCol = dCol + 1
Else
Exit Do
End If
Loop
rs.Update
dRow = dRow + 1
Loop
EXITSUB:
Set mySheet = Nothing
Set xlApp = Nothing
Exit Sub
ERR:
If ERR.Number = 3265 Then MsgBox "The species selected are incompatible. Canceling import.", vbCritical, "IMPORT ERROR"
GoTo EXITSUB
End Sub
Try using
xlApp.Quit
When you set xlApp to nothing you are only clearing the object within the procedure, you aren't doing anything to the actual Excel instance. All that setting XXX = nothing allows you to do is then reuse that object.
You will need to legally close the workbooks that are open as in
xlApp.Workbooks.Close
EXITSUB:
This will close the instances that are open.
Prior to this, kill all the instances or reboot your machine to clear all the instances that are open.

Trying to read certain cells from an xls file through access vba. Trouble with dependency on Excel

I am tasked with making a database in microsoft access to which we store parts list. The lists gets delivered in the excel format .xls.
This worksheet has a field header fields ( distinct cells with data) and a list a few rows below. I can get the code to work IF currently there is a normally opened excel file, for instance your personal.XLSB. If Excel is not running, i get issues in the form of
:error 429. activeX can not create object.
or at times an Error 462 in VBA :
remote server machine not found,
application starts with: Cmd_Inlezen_Stuklijst_Import_Click
i have tried to create an instance of excel running in the background by testing if excel is running the function IsExcelRunning
Application.ScreenUpdating = False
Dim src As Workbook
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
Set src = Workbooks.Open(Me!TxtFullPath)
src.Close False ' FALSE - DON'T SAVE THE SOURCE FILE.
Set src = Nothing
sometimes this seems toworks, but i haven't been able to determine exactly how.
i LITERALLY copied https://social.msdn.microsoft.com/Forums/en-US/ffd5975b-83fa-4d64-94af-7230f0058a3d/opening-an-excel-file-from-ms-access?forum=isvvba
then changed the path to the file i need, but as long as excel is NOT running, it doesn't work.
instead of CreateObject, I also tried GetObject but same 429 error
The code in the if statement after i check the status of excel is also according to example. ( source no longer known to me)
I have the references turned on Microsoft Excel 14 object library.
'***************************************************************************
'Purpose: check if excel is running 0 als onwaar -1 als waar
'Inputs
'Outputs: boolean
'***************************************************************************
Public Function IsExcelRunning() As Boolean '
Dim xl As Object
On Error Resume Next
Set xl = GetObject(, "Excel.Application")
IsExcelRunning = (Err.Number = 0)
Set xl = Nothing
End Function
'***************************************************************************
'Purpose: pikt de kop gegevens van het formulier op.
'Inputs:
'A2 leeg
'B2 stuklijstNaam
'C2 editie klant
'D2 Editie Debrug
'E2 Stuklijstomschrijving
'F2 creatiedatum
'G2 ontvangstdatum
'H2 werktijd
'I2 Default aantal
'J2 klant naam
'B3 eindproduct
'B3 eindproduct omschrijving
'Outputs: boolean
'***************************************************************************
Function MiscDataFetch() As Boolean 'leest headers
Dim my_xl_app As Object
Dim my_xl_worksheet As Object
Dim my_xl_workbook As Object
Set my_xl_app = CreateObject("Excel.Application")
my_xl_app.UserControl = True
my_xl_app.Visible = False ' yes. I know it's the default
'WasteTime (2)
Set my_xl_workbook = GetObject(Me!TxtFullPath)
'Set my_xl_workbook = CreateObject(Me!TxtFullPath)
Set my_xl_worksheet = my_xl_workbook.Worksheets(1)
Me!FilStuklijstNaam = my_xl_worksheet.Cells(2, "B")
Me!FilEditieKlant = my_xl_worksheet.Cells(2, "C")
Me!FilEditieDeBrug = my_xl_worksheet.Cells(2, "D")
Me!FilStuklijstOmschrijving = my_xl_worksheet.Cells(2, "E")
Me!FilCreatieDatum = my_xl_worksheet.Cells(2, "F")
Me!FilOntvangstDatum = my_xl_worksheet.Cells(2, "G")
Me!FilWerktijd = my_xl_worksheet.Cells(2, "H")
Me!filDefaultAantal = my_xl_worksheet.Cells(2, "I")
Me!FilKlantNaam = my_xl_worksheet.Cells(2, "J")
Me!FilEindpoduct = my_xl_worksheet.Cells(3, "B")
Me!FilEindproductOmschr = my_xl_worksheet.Cells(3, "E")
my_xl_workbook.Close SaveChanges:=False
Set my_xl_app = Nothing
Set my_xl_workbook = Nothing
Set my_xl_worksheet = Nothing
MiscDataFetch = True
End Function
Sub WasteTime(Finish As Long)
Dim NowTick As Long
Dim EndTick As Long
EndTick = GetTickCount + (Finish * 1000)
Do
NowTick = GetTickCount
GetTickCount = GetTickCount + (1)
Loop Until NowTick >= EndTick
End Sub
'***************************************************************************
'Purpose: controleert de kopgegevens
'Inputs
'Outputs: boolean True: alle gegevens voorzien
' False: er zijn velden nieet ingevuld
'***************************************************************************
Function FullMiscDataFetch() As Boolean
FullMiscDataFetch = True
Dim Fullfilled As Integer
If Me!FilStuklijstNaam = "" Then Fullfilled = Fullfilled + 1
If Me!FilEditieKlant = "" Then Fullfilled = Fullfilled + 1
If Me!FilEditieDeBrug = "" Then Fullfilled = Fullfilled + 1
If Me!FilStuklijstOmschrijving = "" Then Fullfilled = Fullfilled + 1
If Me!FilCreatieDatum = "" Then Fullfilled = Fullfilled + 1
If Me!FilOntvangstDatum = "" Then Fullfilled = Fullfilled + 1
If Me!FilWerktijd = "" Then Fullfilled = Fullfilled + 1
If Me!filDefaultAantal = "" Then Fullfilled = Fullfilled + 1
If Me!FilKlantNaam = "" Then Fullfilled = Fullfilled + 1
If Me!FilEindpoduct = "" Then Fullfilled = Fullfilled + 1
If Me!FilEindproductOmschr = "" Then Fullfilled = Fullfilled + 1
If Fullfilled > 1 Then
MsgBox "Niet alle detailvelden bevatten gegevens." & vbCrLf & "Vul de gegevens aan en probeer opnieuw."
FullMiscDataFetch = False
End If
End Function
'***************************************************************************
'Purpose: inleescommando voor deze pagina (Frm_stuklijst_Import).
'Inputs
'Outputs:
'***************************************************************************
Private Sub Cmd_Inlezen_Stuklijst_Import_Click() 'commando voor lijst MET headers
Dim SQLKlantUpdate As String
Dim SQLKlantIDUpdate As String
'DoCmd.RunSQL "DELETE * FROM Tbl_Stuklijst_Import" 'opschonen werkblad
'opschonen
'SubFrm_Tbl_Stuklijst_Import.Requery 'updaten van visueel gegeven lege lijst
If IsExcelRunning Then
Else
'Application.ScreenUpdating = False
'Dim src As Workbook
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
'Set src = Workbooks.Open(Me!TxtFullPath)
'src.Close False ' FALSE - DON'T SAVE THE SOURCE FILE.
'Set src = Nothing
End If
MiscDataFetch 'get header comments
'FetchData 'get material list
FullMiscDataFetch 'controle of alle velden info bevatten
End Sub
expected result is that the distinct cells are read and transferred to fields in the form, whether excel is running or not, and without the need for the user to intervene by activating Excel to bypass the error.
I need to somehow catch the difference in method whether excel is running or not.
Try this to open and close an Excel file:
Dim xl As Excel.Application
Dim xlBook As Excel.workbook
Dim xlSheet As Excel.worksheet
Set xl = New Excel.Application
Set xlBook = xl.Workbooks.Open(Filename)
Set xlSheet = xlBook.Worksheets(1)
…
xlBook.Close
Set xlSheet = Nothing
Set xlBook = Nothing
Set xl = Nothing
If you are using types of Excel as in
Dim wb As Excel.Workbook
then you must have a reference to Excel; however, if you are working with Late Binding as in
Dim wb As Object 'Excel.Workbook
Then remove the reference to Excel. This has the advantage that your code will work with different versions of Excel. Otherwise you are tied to a specific version. Often I use early binding (first method) during development and then switch to Object for all library-specific types and remove the reference. This makes the Access application more stable.
I usually use this code to get the application. If the application is open I return it (GetObject), otherwise I create it (CreateObject). Here shown with Word:
Public Function GetWordApplication() As Object
'Gets an active Word application or opens a new Word instance.
'Raises Error No. 8 if word cannot be opened.
On Error Resume Next
'Find existing instance of Word
Set GetWordApplication = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Not found, create new instance.
Set GetWordApplication = CreateObject("Word.Application")
End If
On Error GoTo 0
If GetWordApplication Is Nothing Then
Err.Raise 8, "YourApp.GetWordApplication", "Word could not be opened."
End If
End Function

how to load data from excel to word

I want to implement the vba-code into my word-document:
how to load Cell(1,1) from sheet1 from a Excel-Document (lets say ist Path is C:\Test\Excel.xlsx) into current Word Document. In the word document already exist a table(2x2). Want to insert it into first cell of table.
Many thanks!
These solutions use late-binding to communicate Word - Excel
See here to learn more about late vs early binding
Steps to communicate from Word to Excel and insert the text back into Word.
Follow these steps:
In Word:
1) Insert a bookmark in your word's table cell and name it "FirstCell"
2) Add a module
3) Copy/paste this code and adapt the '<<< Customize this >>>' section
Code:
Sub InsertFromWordIntoExcel()
Dim oExcel As Object
Dim excelDocument As Object
Dim bookmarkRange As Range
Dim bookmarkName As String
Dim excelWorkbookPath As String
Dim exceWorkbookName As String
Dim sheetName As String
Dim cellContentAddress As String
' <<< Customize this >>>
excelWorkbookPath = "C:\Test\" ' include backslash at the end
exceWorkbookName = "Excel.xlsx"
bookmarkName = "FirstCell"
sheetName = "Sheet1"
cellContentAddress = "A1"
' Check if Excel is already opened
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
' Open a new instance
Set oExcel = CreateObject("Excel.Application")
oExcel.Visible = True
End If
' Check if document is already open
Set excelDocument = oExcel.Workbooks(exceWorkbookName)
If Err.Number <> 0 Then
' Open excel workbook
Set excelDocument = oExcel.Workbooks.Open(excelWorkbookPath & exceWorkbookName)
End If
' Reset error handling
Err.Clear
On Error GoTo 0
' Get the bookmark range
Set bookmarkRange = ThisDocument.Bookmarks(bookmarkName).Range
' Insert the cells text
bookmarkRange.Text = excelDocument.Sheets(sheetName).Range(cellContentAddress).Value
' Add the bookmark again
ThisDocument.Bookmarks.Add bookmarkName, bookmarkRange
End Sub
Alternative, to communicate from Excel and insert the cell's text into Word.
1) Add the bookmark in Word (as mentioned above)
2) Add a module in Excel
3) Copy/paste this code and adapt the '<<< Customize this >>>' section
Sub InsertFromExcelIntoWord()
Dim oWord As Object
Dim wordDocument As Object
Dim bookmarkRange As Object
Dim wordDocumentPath As String
Dim wordDocumentName As String
Dim bookmarkName As String
Dim sheetName As String
Dim cellContentAddress As String
' <<< Customize this >>>
wordDocumentPath = "C:\Test\" ' include backslash at the end
wordDocumentName = "Word.docx"
bookmarkName = "FirstCell"
sheetName = "Sheet1"
cellContentAddress = "A1"
' Check if Word is already opened
On Error Resume Next
Set oWord = GetObject(, "Word.Application")
If Err.Number <> 0 Then
' Open a new instance
Set oWord = CreateObject("Word.Application")
oWord.Visible = True
End If
' Check if document is already open
Set wordDocument = oWord.documents(wordDocumentName)
If Err.Number <> 0 Then
' Open word document
Set wordDocument = oWord.documents.Open(wordDocumentPath & wordDocumentName)
End If
' Reset error handling
Err.Clear
On Error GoTo 0
' Get the bookmark range
Set bookmarkRange = wordDocument.Bookmarks(bookmarkName).Range
' Insert the cells text
bookmarkRange.Text = ThisWorkbook.Sheets(sheetName).Range(cellContentAddress).Value
' Add the bookmark again
wordDocument.Bookmarks.Add bookmarkName, bookmarkRange
End Sub

A couple of questions about Word macros

I need to grab a list of names from Excel and insert them into a Word document, printing one document per name. The document has some text and a bookmark called "name". The code is below.
First, I want to know if it's possible to detect how long is the list of names in the Excel spreadsheet and grab that, instead of hardcoding the number.
Second, I can't figure out how to delete the text I already put inside the document. When I insert text in a bookmark, it gets appended after the bookmark, so if I keep adding names they all stack together.
Maybe with the code this will be clearer:
Sub insertar_nombre()
Dim Excel As Excel.Application
Dim Planilla As Excel.Workbook
Dim Hoja As Excel.Worksheet
Set Excel = CreateObject("Excel.Application")
Dim Filename As String
Dim fname As Variant
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Title = "Seleccionar Documento de Excel"
.Show
For Each fname In .SelectedItems
Filename = fname
Next
End With
Set Planilla = Excel.Workbooks.Open(Filename)
Set Hoja = Planilla.Worksheets(1)
Dim Nombre As String
For Count = 2 To 10
Nombre = Hoja.Cells(Count, 1).Value
ActiveDocument.Bookmarks("name").Range.Text = Nombre
ActiveDocument.PrintOut
Next
End Sub
Forgive me if this code is obviously wrong or something, I'm just beginning with this.
I need to grab a list of names from Excel and insert them into a Word document, printing one document per name.
Why don't you simply use the mail merge feature?
the following Sub should solve this for you, but you might need to change the way your bookmark is defined.
There is more than one way to insert a Bookmark. This method requires the Bookmark to be inserted by highlighting the text, not simply positioning the cursor at a location in the text.
Sub insertar_nombre()
Dim xlWorkbook As Excel.Workbook
Dim xlWorksheet As Excel.Worksheet
Dim strFilename As String
Dim bkmName As Word.Range
Dim strBookmarkOriginalText As String
Dim lngRowLast As Long
Dim rngRowStart As Excel.Range
Dim rngRowEnd As Excel.Range
Dim rngNames As Excel.Range
Dim rngName As Excel.Range
'Open file dialog and only allow Excel files'
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Title = "Seleccionar Documento de Excel"
'Only let them select Excel files'
.Filters.Clear
.Filters.Add "Excel Documents (*.xls)", "*.xls"
'Check if a file is selected'
If .Show = True Then
'Since AllowMultiSelect is set to False, _
only one file can be selected'
strFilename = .SelectedItems(1)
Else
'No file selected, so exit the Sub'
Exit Sub
End If
End With
'Set the bookmark to a Word range (not a Bookmark object)'
Set bkmName = ActiveDocument.Bookmarks("name").Range
'Save the original text of the bookmark'
strBookmarkOriginalText = bkmName.Text
'Open the Excel file'
Set xlWorkbook = Excel.Workbooks.Open(strFilename)
Set xlWorksheet = xlWorkbook.Worksheets(1)
'Range of the first cell that contains a name'
Set rngRowStart = xlWorksheet.Cells(2, 1)
'Range of the last cell in the column'
lngRowLast = xlWorksheet.Range("A65536").End(xlUp).Row
Set rngRowEnd = xlWorksheet.Cells(lngRowLast, 1)
'Range of all cells from first name cell to last name cell'
Set rngNames = xlWorksheet.Range(rngRowStart, rngRowEnd)
'Loop through the range of names'
For Each rngName In rngNames
'Ignore any blank cells'
If rngName <> vbNullString Then
'Set the text of the bookmark range to the name from Excel'
bkmName.Text = rngName
'The above statement deleted the Bookmark, so create _
a new Bookmark using the range specified in bkmName'
ActiveDocument.Bookmarks.Add Name:="name", Range:=bkmName
'Print the document'
ActiveDocument.PrintOut
End If
Next
'Restore the orignal value of the bookmark'
bkmName.Text = strBookmarkOriginalText
ActiveDocument.Bookmarks.Add Name:="name", Range:=bkmName
'Close the Workbook without saving'
xlWorkbook.Close SaveChanges:=False
End Sub
Hope this helps.

Resources