Mail merge in word for mailing labels with excel.

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.

Code:

---


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

thanks buddy :)

Hi, I am trying to mail merge excel data with 207 rows and 7 columns with the same code in Microsoft 2010.I get an 'Incorrect Error User-defined type' error.Can someone please help me with the code. Thanks