Fill Down based on variable, offset?

C

CarpeDiemFL

Hi all and thanks for such an AMAZING site! You've vicariously gotte
me out of several programming jams in the past, and I'm now a littl
embarrassed to find myself between a code and a hard place.

I am writing (trying, anyway) VBA to do the following:

Once a macro is executed, excel looks at rows that have the followin
information:

ColA ColB ColC ColD
ITEM# SLOT# DESCRIPTION # of Labels
5301 DF212 Black Beans 5
1624 CA172 Rice 2

I need to tell excel to (on a different sheet) create:

5301
Black Beans
DF212
5301
Black Beans
DF212
5301
Black Beans
DF212
5301
Black Beans
DF212
5301
Black Beans
DF212
1624
Rice
CA172
1624
Rice
CA172

...and so on. In other words, I need it to repeat the insert of th
Item#, Slot# and Description specified by what is entered for the #o
Labels.

Having been a great fan of this site for some time now, I know bette
than to ask for a simple "Do it for me". Getting there is half th
fun, so they say. Any help or pointing in the right direction or hint
or clues or web site references would be incredibly appreciated.

Thanks again for such an awesome forum!

Jim C
 
J

J.E. McGimpsey

well, this isn't from ExcelTip or ExcelForum, but...

I'd suggest a modification. If you were to instead copy the # of
labels' worth to rows, e.g.:

5301 Black Beans DF212
5301 Black Beans DF212
...

You can then use Word's data merge feature to easily create labels.

Public Sub RejiggerDataHorizontally()
Dim vArr(1 To 1, 1 To 3) As Variant
Dim rCell As Range
Dim rDest As Range
Dim i As Integer
Set rDest = Sheets("Sheet2").Range("A1")
For Each rCell In Sheets("Sheet1").Range("A2:A" & _
Range("A" & Rows.Count).End(xlUp).Row)
With rCell
vArr(1, 1) = .Value
vArr(1, 2) = .Offset(0, 2).Value
vArr(1, 3) = .Offset(0, 1).Value
For i = 0 To .Offset(0, 3).Value - 1
rDest.Offset(i, 0).Resize(1, 3).Value = vArr
Next i
Set rDest = rDest.Offset(i, 0)
End With
Next rCell
End Sub

If instead you want the format you've laid out:

Public Sub RejiggerDataVertically()
Dim vArr(1 To 3, 1 To 1) As Variant
Dim rCell As Range
Dim rDest As Range
Dim i As Integer
Set rDest = Sheets("Sheet2").Range("A1")
For Each rCell In Sheets("Sheet1").Range("A2:A" & _
Range("A" & Rows.Count).End(xlUp).Row)
With rCell
vArr(1, 1) = .Value
vArr(2, 1) = .Offset(0, 2).Value
vArr(3, 1) = .Offset(0, 1).Value
For i = 0 To .Offset(0, 3).Value - 1
rDest.Offset(i * 3, 0).Resize(3, 1).Value = vArr
Next i
Set rDest = rDest.Offset(i * 3, 0)
End With
Next rCell
End Sub
 
G

George Nicholson

Oops, this may be too close to "do it for me" for you. Sorry :)

On the other hand, this is entirely off the top of my head & untested,
so there are probably enough syntax goofs to keep you busy in online Help.
It should at least give you some ideas.

Key to my approach is to avoid using the expensive Select and Activate
methods as much as humanly possible.

*****************************************
Dim wksSource as worksheet
Dim rngTarget as range

Dim lngSourceRows as long ' # of rows in SourceData
Dim r as Long 'Current Row

Dim intLabels as integer '# of labels
Dim i as integer 'Current Label


Set wksSource = Sheets("SourceData")
'Set target anchor to 1st empty cell on sheet. ** Change cell address if
necessary **
Set rngTarget = Sheets("TargetData").range("A1")

lngSourceRows = wksSource.usedrange.rows.count

for r = 1 to lngSourceRows '**Change starting row if there are headers
in the source data**
iLabels = wksSource.cells(r,4)
'Create iLabel # of labels in Column A
For i = 1 to iLabels ' **Assumes iLabel value won't EVER be
zero. **
rngTarget = wksSource.cells(r,1) 'Copy ColA
value
rngTarget.offset(1,0) = wksSource.cells(r,3) ' Copy ColC value
rngTarget.offset(2,0) = wksSource.cells(r,2) ' Copy ColB value
'Set anchor to the next empty cell. **If you want a blank line
before the next label, change to offset(4,0)**
set rngTarget = rngTarget.offset(3,0)
next i
Next r
*************************************

Hope this helps, but not too much,
 
C

CarpeDiemFL

Your quick and succinct response is very much appreciated and I can'
wait to test it out. I'll let you know how successful I was.

Many thanks again!

Jim C
 
J

J.E. McGimpsey

Try this instead - don't know why I insisted on the loop:

Public Sub RejiggerDataHorizontally()
Dim vArr(1 To 1, 1 To 3) As Variant
Dim rCell As Range
Dim rDest As Range
Dim nRows As Integer
Set rDest = Sheets("Sheet2").Range("A1")
For Each rCell In Sheets("Sheet1").Range("A2:A" & _
Range("A" & Rows.Count).End(xlUp).Row)
With rCell
vArr(1, 1) = .Value
vArr(1, 2) = .Offset(0, 2).Value
vArr(1, 3) = .Offset(0, 1).Value
nRows = .Offset(0, 3).Value
rDest.Resize(nRows, 3).Value = vArr
Set rDest = rDest.Offset(nRows, 0)
End With
Next rCell
End Sub
 
Top