Option Explicit
Sub writeInstances()
Const FirstRow As Long = 2
Const srcValue As Variant = "A"
Const srcCount As Variant = "B"
Const tgtValue As Variant = "C"
' Define Value Processing Range.
Dim rng As Range
Set rng = Range(Cells(FirstRow, srcValue), _
Cells(Rows.Count, srcValue))
' Define Value Last Cell Range.
Dim cel As Range
Set cel = rng.Find(What:="*", _
LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
' Validate Value Last Cell Range.
If cel Is Nothing Then
GoTo ProcExit
End If
' Define Value Column Range.
Set rng = Range(rng.Cells(1), cel)
' Write values from Value and Count Column Ranges to arrays of Source Array.
Dim OneCell As Variant
ReDim OneCell(1 To 1, 1 To 1)
Dim Source As Variant
ReDim Source(1 To 2)
If rng.Rows.Count > 1 Then
Source(1) = rng.Value
Source(2) = rng.Offset(, Columns(srcCount).Column _
- Columns(srcValue).Column).Value
Else
Source(1) = OneCell
Source(1)(1, 1) = rng.Value
Source(2)(1, 1) = rng.Offset(, Columns(srcCount).Column _
- Columns(srcValue).Column).Value
End If
' Write values from Source Array to Target Array.
Dim Target As Variant
Dim CurrentValue As Variant
Dim CountValue As Variant
ReDim Target(1 To WorksheetFunction.Sum(Source(2)), 1 To 1)
Dim i As Long
Dim j As Long
Dim k As Long
For i = 1 To UBound(Source(1))
CountValue = Source(2)(i, 1)
If VarType(CountValue) = vbDouble Then
CountValue = CLng(CountValue)
If CountValue > 0 Then
CurrentValue = Source(1)(i, 1)
For j = 1 To CountValue
k = k + 1
Target(k, 1) = CurrentValue
Next j
End If
End If
Next i
If k = 0 Then
GoTo ProcExit
End If
' Copy values from Target Array to Target Column Range.
Set cel = rng.Cells(1).Offset(, Columns(tgtValue).Column _
- Columns(srcValue).Column)
cel.Resize(Rows.Count - cel.Row + 1).Clear
cel.Resize(k).Value = Target
ProcExit:
End Sub