repeat entry based on value in cell

[T. Valko]

Hi Folks!

I'm helping someone over in the .Functions group. It's a data extraction
problem.

Here's what we have:

................header1.....header2.....header3.....Count
Data1.......date1.........date2........date3...........2
Data2.......date1.........date2........date3...........1
Data3........................date2........date3............0
Data4.......date1........date2.............................2
Data5.........................................date3............1

The count column is the numbers of dates that Data(n) meets a criteria, the
month number.

We need to create a list of Data(n) that repeats based on the number in the
Count column. Like this:

Data1
Data1
Data2
Data4
Data4
Data5

I can do this with a couple of helper formulas but it is a real PITA and is
the hardest part of solving this problem. We need this list output to a
different sheet.

Thanks!

Biff

 

[Tom Ogilvy]

Sub buildlist()
Dim rng As Range
Dim cell As Range, rw As Long
Dim sh As Worksheet, i As Long
Set sh = Worksheets("Dest")
With Worksheets("Data")
Set rng = .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
End With
rw = 2
For Each cell In rng
For i = 1 To cell.Offset(0, 4).Value
sh.Cells(rw, 1).Value = cell.Value
rw = rw + 1
Next i
Next cell
End Sub

 

[Chip Pearson]

Biff,

I'd use a VBA function to do this, something like what follows. Pass in with
absolute cell references the range that has your data names (your "Data1",
"Data2" range), and the range that contains the CountNumbers. Something
like

=FillOutFromValues($A$1:$A$5,$B$1:$B$5)

Array enter that formula in to a range containing at least SUM(CountNumbers)
rows. If the formula is entered in to more than SUM(CountNumbers) rows, the
last elements of the array are set to vbNullStrings and will show up as
blanks in the worksheet. If the formula is entered into less than
SUM(CountNumbers) rows, elements at the end of the array are not displayed.

Function FillOutFromValues(DataNameRange As Range, _
CountRange As Range) As Variant

Dim ResultArr() As Variant
Dim ResultRowCount As Long
Dim Ndx As Long
Dim CountNdx As Long
Dim ResultNdx As Long

If DataNameRange.Columns.Count > 1 Then
FillOutFromValues = CVErr(xlErrRef)
Exit Function
End If
If CountRange.Columns.Count > 1 Then
FillOutFromValues = CVErr(xlErrRef)
Exit Function
End If

If DataNameRange.Rows.Count <> CountRange.Rows.Count Then
FillOutFromValues = CVErr(xlErrRef)
Exit Function
End If

On Error Resume Next
If IsObject(Application.Caller) = False Then
FillOutFromValues = CVErr(xlErrRef)
Exit Function
End If

ResultRowCount = Application.WorksheetFunction.Max( _
Application.WorksheetFunction.Sum(CountRange), _
Application.Caller.Rows.Count)

ReDim ResultArr(1 To ResultRowCount)

ResultNdx = 0
For Ndx = 1 To DataNameRange.Rows.Count
For CountNdx = 1 To CountRange.Cells(Ndx, 1)
ResultNdx = ResultNdx + 1
ResultArr(ResultNdx) = DataNameRange.Cells(Ndx)
Next CountNdx
Next Ndx

For ResultNdx = ResultNdx + 1 To ResultRowCount
ResultArr(ResultNdx) = vbNullString
Next ResultNdx

FillOutFromValues = Application.Transpose(ResultArr)

End Function


--
Cordially,
Chip Pearson
Microsoft MVP - Excel
Pearson Software Consulting, LLC
www.cpearson.com
(email address is on the web site)

 

[T. Valko]

Thanks, Tom. Works great!

Biff

Sub buildlist()
Dim rng As Range
Dim cell As Range, rw As Long
Dim sh As Worksheet, i As Long
Set sh = Worksheets("Dest")
With Worksheets("Data")
Set rng = .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
End With
rw = 2
For Each cell In rng
For i = 1 To cell.Offset(0, 4).Value
sh.Cells(rw, 1).Value = cell.Value
rw = rw + 1
Next i
Next cell
End Sub

 

[T. Valko]

That's a good idea, Chip. Helps make things dynamic. I'll play around with
this and see how it goes.

Thanks!

Biff

 

[T. Valko]

Ok... I played with the UDF and it also works very well. I like both methods
but I'll let the OP decide which method to use.

Thanks guys!

Biff

 

[T. Valko]

After some more testing I've discovered that it's best to clear any
previously built list so I added this line:

sh.Range("A2:A65536").ClearContents

Biff