Scribd
Upload
14 views

Word To Excel Pack

a

Uploaded by

Jharen Sanqui
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
14 views

Word To Excel Pack

a

Uploaded by

Jharen Sanqui
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
You are on page 1/ 3

Option Explicit

Sub Rectangle2_Click()
'
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Substituting excel to word bookmark
Dim objX As Object
Dim rng1 As Range
Dim rng2 As Range
Dim wb As Workbook
Dim wsControl As Worksheet
Dim wsData As Worksheet
'
Dim oApp As Word.Application
Dim oBookMark As Word.Bookmark
Dim oDoc As Word.Document
'
Dim strDocumentFolder As String
Dim strTemplate As String
Dim strTemplateFolder As String
Dim strDocumentAddress As String
Dim lngTemplateNameColumn As Long
Dim strWordDocumentName As String
Dim lngDocumentNameColumn As Long
Dim lngRecordKount As Long ' not used but retained for future use

Set wb = ThisWorkbook
Set wsControl = wb.Worksheets("Control Sheet")
wsControl.Activate

Set wsData = wb.Worksheets(wsControl.[Data_Sheet].Value)


strTemplateFolder = wsControl.[Template_Folder].Value
strDocumentFolder = wsControl.[Document_Folder].Value
strDocumentAddress = wsControl.[Document_address].Value
wsData.Activate

lngTemplateNameColumn = wsData.[Template_Name].Column
lngDocumentNameColumn = wsData.[Document_Name].Column

'
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Create Folder
Dim rootDirectory As String
Dim folderToBeCreated As String
Dim path As String
' Set the root directory path
' where you want to create
' your folder
' Path for MkDir VBA function
' would be the concatination
' of above two
' Check the root directory and folder path
' before creating it directly
If Len(Dir(strDocumentFolder, vbDirectory)) = 0 Then ' full path should
not exist already
VBA.MkDir (strDocumentFolder) ' or VBA.MkDir ("C:\Vishwa\MyFolders\
MyFolder1")
MsgBox "Folder is created successfully"
Else
MsgBox "Folder is already existing in the root directory"
End If
'
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

' number of letters required:


' must not have any blank cells in column A - except at the end
Set rng1 = wsData.Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
lngRecordKount = rng1.Rows.Count
'
'Set oApp = CreateObject("Word Application")
Set oApp = New Word.Application
' Process each record in turn
For Each rng2 In rng1
strTemplate = strTemplateFolder & "\" & wsData.Cells(rng2.Row,
lngTemplateNameColumn)
strWordDocumentName = strDocumentFolder & "\" & wsData.Cells(rng2.Row,
lngDocumentNameColumn)
' check that template exists
If Dir(strTemplate) = "" Then
MsgBox strTemplate & " not found"
GoTo Tidy_Exit
End If

Set oDoc = oApp.Documents.Add


oApp.Selection.InsertFile strTemplate

With oDoc.PageSetup
.TopMargin = CentimetersToPoints(2)
.LeftMargin = CentimetersToPoints(1.52)
.RightMargin = CentimetersToPoints(1.52)
.BottomMargin = CentimetersToPoints(0.63)
.HeaderDistance = CentimetersToPoints(0.5)
.FooterDistance = CentimetersToPoints(0)
.PaperSize = wdPaperA4
End With

' locate each bookmark


For Each oBookMark In oDoc.Bookmarks
Set objX = wsData.Rows(1).Find(oBookMark.name, LookIn:=xlValues,
LookAt:=xlWhole)
If Not objX Is Nothing Then
' found
If Right(oBookMark.name, 9) = "DateToday" Then
oBookMark.Range.Text = Format(wsData.Cells(rng2.Row, objX.Column),
"mmmm dd, yyyy")
Else
oBookMark.Range.Text = wsData.Cells(rng2.Row, objX.Column)
End If
Else
MsgBox "Bookmark '" & oBookMark.name & "' not found", vbOKOnly +
vbCritical, "Error"
GoTo Tidy_Exit
End If
Next oBookMark
'
oDoc.SaveAs strWordDocumentName & ".docx"
oDoc.Close
Next rng2
'
Tidy_Exit:
On Error Resume Next

Set oDoc = Nothing


Set oBookMark = Nothing
Set objX = Nothing
Set rng1 = Nothing
Set rng2 = Nothing

'
Set wsData = Nothing
Set wsControl = Nothing
Set wb = Nothing

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
MsgBox ("Letters Completed")
End Sub

You might also like