Bulevardi
Jun 3rd, 2011, 12:37 PM
If you want to make mailing labels with data from an Excel table, so you can mail merge this in Word, you can do it automatically with a simple VBA script.
Requirements: Excel and Word 2010, awareness of your VBA editor.
Note: tested in Office version 2010. Not sure if it will work in Office 2007 or older versions.
Sub create_labels()
Dim strThisWorkbook As String
strThisWorkbook = ThisWorkbook.FullName
' create the word document:
Dim oWORD As Word.Application, wrdDoc As Word.Document, wrdTable As Word.Table
Set oWORD = New Word.Application
Set wrdDoc = oWORD.Documents.Add
' so we can see what is happening in word:
oWORD.Visible = True
wrdDoc.Activate
' adjusting the page setup properties first:
With wrdDoc.PageSetup
.Orientation = wdOrientPortrait
.TopMargin = CentimetersToPoints(1.59)
.BottomMargin = CentimetersToPoints(0)
.LeftMargin = CentimetersToPoints(0.47)
.RightMargin = CentimetersToPoints(0.47)
.Gutter = CentimetersToPoints(0)
.HeaderDistance = CentimetersToPoints(1.25)
.FooterDistance = CentimetersToPoints(1.25)
.PageWidth = CentimetersToPoints(21)
.PageHeight = CentimetersToPoints(29.7)
End With
' creating the table of labels (in this example, 2 columns, 7 rows):
Set wrdRange = wrdDoc.Range
Set wrdTable = wrdDoc.Tables.Add(Range:=wrdRange, NumRows:=7, NumColumns:=2, _
DefaultTableBehavior:=wdWord9TableBehavior, _
AutoFitBehavior:=wdAutoFitFixed)
' adjusting the table properties:
With wrdTable
.Columns.PreferredWidth = CentimetersToPoints(9.9)
.TopPadding = CentimetersToPoints(0)
.BottomPadding = CentimetersToPoints(0)
.LeftPadding = CentimetersToPoints(0.3)
.RightPadding = CentimetersToPoints(0.3)
.Rows.HeightRule = wdRowHeightExactly
.Rows.Height = CentimetersToPoints(3.81)
.Rows.Alignment = wdAlignRowCenter
.Spacing = 0
.AllowPageBreaks = True
.AllowAutoFit = True
.AutoFitBehavior (wdAutoFitFixed)
.AutoFitBehavior (wdAutoFitFixed)
.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Borders(wdBorderRight).LineStyle = wdLineStyleNone
.Borders(wdBorderTop).LineStyle = wdLineStyleNone
.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
.Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
.Borders(wdBorderVertical).LineStyle = wdLineStyleNone
.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
.Borders.Shadow = False
End With
' getting the range of data from out excel data tabel:
Range(Rng("Sheet1")).Select
' finally, processing the data into our labels with a mail merge:
With oWORD.MailingLabel.Application.ActiveDocument
.mailmerge.MainDocumentType = wdMailingLabels
' choosing the right document and data table:
.mailmerge.OpenDataSource ThisWorkbook.FullName, ConfirmConversions = "False", ReadOnly = "False", _
LinkToSource = "True", AddToRecentFiles = "False", , , , , , , _
"Data Source=" & strThisWorkbook & ";Mode=Read", _
"SELECT * FROM `Sheet1$`"
.mailmerge.DataSource.ActiveRecord = wdFirstRecord
' iterate through each label:
' for each row (in excel):
For r = 4 To .mailmerge.DataSource.RecordCount
' for each field (in excel):
For f = .mailmerge.DataSource.DataFields.Count To 1 Step -1
.Application.Selection = .mailmerge.DataSource.DataFields.Item(f).Value & vbCrLf
Next f
' go to the next row (in excel):
.mailmerge.DataSource.ActiveRecord = (r + 1)
' go to the next label (in word):
.Application.Selection.MoveRight Unit:=wdCell
Next r
' to be sure your data is visible:
.mailmerge.ViewMailMergeFieldCodes = wdToggle
End With
' no closures for your word object needed as you close your word app later on yourself.
End Sub
Function Rng(Optional WorksheetName As String)
' the RNG range makes the range from A6 to C lastrow
Dim LastRow As Integer
Dim lastcol As String
lastcol = "C"
If WorksheetName = vbNullString Then
WorksheetName = ActiveSheet.Name
End If
With Worksheets(WorksheetName)
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
Rng = "A6:" & lastcol & LastRow
End Function
More explanation and a working example as live demo to download right here:
http://bulevardi.be/?content=scripting&example=exvb3
Requirements: Excel and Word 2010, awareness of your VBA editor.
Note: tested in Office version 2010. Not sure if it will work in Office 2007 or older versions.
Sub create_labels()
Dim strThisWorkbook As String
strThisWorkbook = ThisWorkbook.FullName
' create the word document:
Dim oWORD As Word.Application, wrdDoc As Word.Document, wrdTable As Word.Table
Set oWORD = New Word.Application
Set wrdDoc = oWORD.Documents.Add
' so we can see what is happening in word:
oWORD.Visible = True
wrdDoc.Activate
' adjusting the page setup properties first:
With wrdDoc.PageSetup
.Orientation = wdOrientPortrait
.TopMargin = CentimetersToPoints(1.59)
.BottomMargin = CentimetersToPoints(0)
.LeftMargin = CentimetersToPoints(0.47)
.RightMargin = CentimetersToPoints(0.47)
.Gutter = CentimetersToPoints(0)
.HeaderDistance = CentimetersToPoints(1.25)
.FooterDistance = CentimetersToPoints(1.25)
.PageWidth = CentimetersToPoints(21)
.PageHeight = CentimetersToPoints(29.7)
End With
' creating the table of labels (in this example, 2 columns, 7 rows):
Set wrdRange = wrdDoc.Range
Set wrdTable = wrdDoc.Tables.Add(Range:=wrdRange, NumRows:=7, NumColumns:=2, _
DefaultTableBehavior:=wdWord9TableBehavior, _
AutoFitBehavior:=wdAutoFitFixed)
' adjusting the table properties:
With wrdTable
.Columns.PreferredWidth = CentimetersToPoints(9.9)
.TopPadding = CentimetersToPoints(0)
.BottomPadding = CentimetersToPoints(0)
.LeftPadding = CentimetersToPoints(0.3)
.RightPadding = CentimetersToPoints(0.3)
.Rows.HeightRule = wdRowHeightExactly
.Rows.Height = CentimetersToPoints(3.81)
.Rows.Alignment = wdAlignRowCenter
.Spacing = 0
.AllowPageBreaks = True
.AllowAutoFit = True
.AutoFitBehavior (wdAutoFitFixed)
.AutoFitBehavior (wdAutoFitFixed)
.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Borders(wdBorderRight).LineStyle = wdLineStyleNone
.Borders(wdBorderTop).LineStyle = wdLineStyleNone
.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
.Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
.Borders(wdBorderVertical).LineStyle = wdLineStyleNone
.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
.Borders.Shadow = False
End With
' getting the range of data from out excel data tabel:
Range(Rng("Sheet1")).Select
' finally, processing the data into our labels with a mail merge:
With oWORD.MailingLabel.Application.ActiveDocument
.mailmerge.MainDocumentType = wdMailingLabels
' choosing the right document and data table:
.mailmerge.OpenDataSource ThisWorkbook.FullName, ConfirmConversions = "False", ReadOnly = "False", _
LinkToSource = "True", AddToRecentFiles = "False", , , , , , , _
"Data Source=" & strThisWorkbook & ";Mode=Read", _
"SELECT * FROM `Sheet1$`"
.mailmerge.DataSource.ActiveRecord = wdFirstRecord
' iterate through each label:
' for each row (in excel):
For r = 4 To .mailmerge.DataSource.RecordCount
' for each field (in excel):
For f = .mailmerge.DataSource.DataFields.Count To 1 Step -1
.Application.Selection = .mailmerge.DataSource.DataFields.Item(f).Value & vbCrLf
Next f
' go to the next row (in excel):
.mailmerge.DataSource.ActiveRecord = (r + 1)
' go to the next label (in word):
.Application.Selection.MoveRight Unit:=wdCell
Next r
' to be sure your data is visible:
.mailmerge.ViewMailMergeFieldCodes = wdToggle
End With
' no closures for your word object needed as you close your word app later on yourself.
End Sub
Function Rng(Optional WorksheetName As String)
' the RNG range makes the range from A6 to C lastrow
Dim LastRow As Integer
Dim lastcol As String
lastcol = "C"
If WorksheetName = vbNullString Then
WorksheetName = ActiveSheet.Name
End If
With Worksheets(WorksheetName)
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
Rng = "A6:" & lastcol & LastRow
End Function
More explanation and a working example as live demo to download right here:
http://bulevardi.be/?content=scripting&example=exvb3