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.
More explanation and a working example as live demo to download right here: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
http://bulevardi.be/?content=scripting&example=exvb3




Reply With Quote