Repeating a record

[T. Neil]

Hi--I"m trying to print out labels to use on cartons. The data source is an
excel spreadsheet. I would like to repeat printing a label (a record) a
number of times based on a value in the spreadsheet. For example--in the
spreadsheet I have a column with a number--say it's 3. I would like the mail
merge to repeat the same record 3 times before moving on to the next record.
I've searched and have come up empty handed. Any help would be greatly
appreciated!

Thanks,

 

[Doug Robbins - Word MVP]

You would need to create a data source that contains the necessary number of
rows of data for each of the same type of label that you want to produce.

While I am sure that can be done with a macro in Excel, being more familiar
with macros in Word, I would do it as follows:

Copy and paste the Excel Range containing the data into a Word document, and
then with that document as the active document, run a macro containing the
following code:

Dim source As Document, target As Document
Dim stable As Table, dtable As Table
Dim srow As Row, drow As Row
Dim i As Long, j As Long, k As Long, cols As Long
Dim numlabels As Range, drange As Range
Set source = ActiveDocument
Set target = Documents.Add
Set stable = source.Tables(1)
cols = stable.Columns.Count
Set dtable = target.Tables.Add(Range:=Selection.Range, numrows:=1,
numcolumns:=cols - 1)
For k = 1 To cols - 1
Set drange = stable.Cell(1, k).Range
drange.End = drange.End - 1
dtable.Cell(1, k).Range = drange
Next k
For i = 1 To stable.Rows.Count
Set srow = stable.Rows(i)
Set numlabels = srow.Cells(cols).Range
numlabels.End = numlabels.End - 1
For j = 1 To Val(numlabels.Text)
Set drow = dtable.Rows.Add
For k = 1 To cols - 1
Set drange = srow.Cells(k).Range
drange.End = drange.End - 1
drow.Cells(k).Range = drange
Next k
Next j
Next i

The macro assumes that the column containing the number of labels required
for each record is the last column of data (re-arrange your Excel
spreadsheet if that is not the case) and it creates a new document
containing a table that contains the required number of records for each
destination that can be used as the data source for merging to produce your
labels.

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP

 

[Access101]

I'm still learning VBA in XL, so if someone wants to post a better version of
this back on the site, I'm all for it.

This code assumes your Workbook has two Sheets: the Source is the first
sheet, and the Destination is the second sheet (though names are not
important, just the order within the WB is)

The Source sheet can have up to 10 columns (if you use Company Name, ATTN,
Country, etc., you might begin to approach 10).

Below is an example with just 5 columns with the Count of the Labels in the
first column.

Lbl-Count Address City State Zip
3 123 Place x y z
1 123 Place x y z
2 123 Place x y z

The Lbl-Count column of course, says
print the first address 3 times
the second address 1 time
and the third address 2 times

Let me know how it goes.

Sub RepeatMailingLabels()

Dim wsSRC As Worksheet, wsDEST As Worksheet
Dim strItem(10), CurReg As Range
Dim colCount As Integer
Dim rStart As Integer, lblCount As Integer

Set wsSRC = Sheets(1)
Set wsDEST = Sheets(2)

If ActiveWorkbook.Sheets.Count < 2 Then
MsgBox "Workbook must have at least two Sheets (a SRC and a DEST),
Sheet names are not important.", vbCritical, "Sheet Count"
Exit Sub
Else
answer = MsgBox("This macro will delete all information on Sheet 2
called: " & vbCr & vbCr & Space(5) & "'" & UCase(wsDEST.Name) & "'" & vbCr &
vbCr & "Proceed?", vbQuestion + vbYesNo, "Run Label Maker")
If answer = vbYes Then
wsDEST.Select
Cells.Select
Selection.ClearContents
Range("A1").Select
Else
Exit Sub
End If
End If

wsSRC.Select
wsSRC.Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
Set CurReg = Selection
colCount = CurReg.Columns.Count

For cc = 1 To colCount - 1
wsDEST.Cells(1, cc) = wsSRC.Cells(1, cc + 1)
Next cc

r = 2
While wsSRC.Cells(r, 1) <> ""

wsDEST.Select
wsDEST.Cells(r, 1).Select

If ActiveCell.Offset(1, 0) = "" Then
Else
ActiveCell.End(xlDown).Select
End If

ActiveCell.Offset(1, 0).Select

rStart = ActiveCell.Row
lblCount = (wsSRC.Cells(r, 1) + rStart) - 1

For c = 2 To colCount
strItem(c) = wsSRC.Cells(r, 1).Offset(0, c - 1)
Next c

For rDEST = rStart To lblCount
For c = 2 To colCount
wsDEST.Cells(rDEST, 1).Offset(0, c - 2) = strItem(c)
Next c
Next rDEST

r = r + 1

Wend

wsDEST.Rows(2).Delete

End Sub

 

[Doug Robbins - Word MVP]

I suggest that you post your question to Microsoft.Public.Excel.Programming

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP

 

[Access101]

Doug,

My Reply was not a question, it was a solution to T. Neil's question. As
well as a response to your statement:

"While I am sure that it can be done with a macro in Excel, being more
familiar with macros in Word, I would do it as follows:"

This was the XL version of your Word solution for T. Neil.

I was further influenced by the fact that I saw nothing in the Post that was
re-directing T. Neil to the Microsoft.Public.Excel.Programming group, so I
felt free to post the XL solution in the Word discussion as well.

 

[Doug Robbins - Word MVP]

Sorry about that. It's fairly common for posters to change the identity and
I did not look closely enough at your post.

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP

 

[Peter Jamieson]

Hello Access101,

I was also looking at a way to do this fairly easily in Excel, but am also
pretty inexperienced in Excel VBA (and rather less experienced than Doug in
Word VBA). In fact I would prefer to avoid VBA altogether if possible, and
tried to solve this using Jet SQL, which, given a chance and a bit of
additional infrastructure, lets you generate the required table using a
single SQL statement.

But anyway, the thing I was stuck on was the use of "CurrentRegion" to
select the necessary block of data, which your code helped me with. But I
think yours can be simplified quite a lot, unless there are problems copying
source cells to data cells, or other oddities in the Excel object model that
I'm not aware of.

Here's my current code with some comments that may help you. But I think
Doug's suggestion to follow this up in an Excel group is sound - they will
know much more about the Excel object model, constant and variable naming
conventions, and so on. They may also be able to advise on the best way to
avoid overwriting existing data, creating new sheets and workbooks, dealing
with errors (e.g. exceeding the maximum number of rows in a workbook, which
I haven't tried to deal with here).

Thanks for posting your solution,

Peter Jamieson

-------------------------------------------------------------------------
Sub RepeatMailingLabels()

' Using constants makes it easier to modify the sheets you want to use
' But there are other ways to parameterise this, for example using workbook
and worksheet names

Const sourceSheet = 1 ' the sheet number containing the source data
Const targetSheet = 2 ' the sheet number that will contain the label data
Const countColumn = 1 ' the column in sourceSheet that contains the label
count

' Let's try to declare every variable we use

Dim c As Integer
Dim r As Long
Dim lDestStartRow As Long
Dim lDestRow As Long

' Let's put "Excel." in front of Excel objects. That way, we have a much
better
' chance of using this code even in Word VBA

Dim wsSource As Excel.Worksheet
Dim wsTarget As Excel.Worksheet
Dim mbrAnswer As VbMsgBoxResult
Dim rng2Copy As Excel.Range
Set wsSource = Excel.ActiveWorkbook.Sheets(sourceSheet)
Set wsTarget = Excel.ActiveWorkbook.Sheets(targetSheet)

If ActiveWorkbook.Sheets.Count < 2 Then

' Spell it out! The clearer the better.

MsgBox "Your Workbook must have at least two Sheets. The first sheet is
assumed to be the source of the data, and column one contains the label
count. The second sheet will be overwritten by the results.", vbCritical,
"Sheet Count"
Exit Sub
Else
mbrAnswer = MsgBox("This macro will delete all information on the second
sheet in your workbook: '" & UCase(wsTarget.Name) & "'" & vbCr & vbCr & "Do
you want to proceed?", vbQuestion + vbYesNo, "Run Label Maker")
If mbrAnswer = vbYes Then

' Clear everything in the target worksheet
wsTarget.Cells.Clear
Else
Exit Sub
End If
End If

' Copy the first row

Set rng2Copy = wsSource.Cells(1, 1).CurrentRegion
For c = 1 To rng2Copy.Columns.Count
wsTarget.Cells(1, c) = wsSource.Cells(1, c)
Next c

' set up the starting row in the target

lDestStartRow = 2

' for each row in the source...

For r = 2 To rng2Copy.Rows.Count

....make the number of copies in the target specified in the appropriate
column
For lDestRow = lDestStartRow To lDestStartRow + wsSource.Cells(r,
countColumn) - 1
For c = 1 To rng2Copy.Columns.Count
wsTarget.Cells(lDestRow, c) = wsSource.Cells(r, c)
Next
Next

' remember where to start the next set of copies in the target
lDestStartRow = lDestStartRow + wsSource.Cells(r, countColumn)
Next

' It's good programming practice to release objects that we
' set up

Set wsTarget = Nothing
Set wsSource = Nothing
End Sub

-------------------------------------------------------------------------

 

[Peter Jamieson]

FWIW, this bit...

For lDestRow = lDestStartRow To lDestStartRow + wsSource.Cells(r,
countColumn) - 1
For c = 1 To rng2Copy.Columns.Count
wsTarget.Cells(lDestRow, c) = wsSource.Cells(r, c)
Next
Next

probably needs to copy only the cell values, leaving formulas behind, e.g.

wsTarget.Cells(lDestRow, c).Value = wsSource.Cells(r, c).Value

Perhaps needs the formatting as well, and/or to use Value2 to get rid of
currency values.

On the whole I think it would be advisable to create a new sheet in a new
workbook to contain the output, primarily so that the user has the option of
using DDE to get the data in tose tricky situations where nothing else
works.

Peter Jamieson