Don -
I have a simple macro that fills in a row or column with values between
the first and last cell of the selection. I can fill by linear or
logarithmic interpolation depending on a variable passed to the macro.
'''------------------------------------------------------------
Sub LinFill()
FillUp False
End Sub
'''------------------------------------------------------------
Sub LogFill()
FillUp True
End Sub
'''------------------------------------------------------------
Sub FillUp(blFillType As Boolean)
''' given a selected range, horizontal or vertical, this routine
''' fills in interpolated values between the first and last cells
''' blFillType = False: on a LINEAR basis
''' blFillType = True: on a LOGARITHMIC basis
Dim ActvSht As Worksheet, Slecshun As Range
Dim TopRow As Integer, BottomRow As Integer, RowCt As Integer
Dim LeftCol As Integer, RiteCol As Integer, ColCt As Integer
Dim Counter As Integer
Dim first As Double, Last As Double
Set ActvSht = ActiveSheet
Set Slecshun = Selection
TopRow = Slecshun.Row
RowCt = Slecshun.Rows.count
BottomRow = RowCt + TopRow - 1
LeftCol = Slecshun.Column
ColCt = Slecshun.Columns.count
RiteCol = ColCt + LeftCol - 1
If Selection.Areas.count > 1 Then
MsgBox "Does not work on multiple selected areas."
GoTo ExitRoutine
End If
If ColCt > 1 And RowCt > 1 Then
MsgBox "Select a one-dimensional array of cells."
GoTo ExitRoutine
End If
Select Case VarType(ActvSht.Cells(TopRow, LeftCol).Value)
Case vbDouble
first = ActvSht.Cells(TopRow, LeftCol)
Case vbEmpty, vbString
MsgBox "Invalid starting cell."
GoTo ExitRoutine
End Select
Select Case VarType(ActvSht.Cells(BottomRow, RiteCol).Value)
Case vbDouble
Last = ActvSht.Cells(BottomRow, RiteCol)
Case vbEmpty, vbString
MsgBox "Invalid ending cell."
GoTo ExitRoutine
End Select
If blFillType Then
If first <= 0 Or Last <= 0 Then
MsgBox "Logarithmic fill requires positive arguments."
GoTo ExitRoutine
End If
End If
If TopRow = BottomRow Then ''' horizontal
If ColCt <= 2 Then
MsgBox "There are no cells to fill in."
GoTo ExitRoutine
Else
For Counter = LeftCol + 1 To RiteCol - 1 Step 1
If blFillType Then
ActvSht.Cells(TopRow, Counter) = _
Exp(Log(first) + (Log(Last) - Log(first)) * _
(Counter - LeftCol) / (RiteCol - LeftCol))
Else
ActvSht.Cells(TopRow, Counter) = _
first + (Last - first) * _
(Counter - LeftCol) / (RiteCol - LeftCol)
End If
Next Counter
End If
ElseIf LeftCol = RiteCol Then ''' vertical
If RowCt <= 2 Then
MsgBox "There are no cells to fill in."
GoTo ExitRoutine
Else
For Counter = TopRow + 1 To BottomRow - 1 Step 1
If blFillType Then
ActvSht.Cells(Counter, LeftCol) = _
Exp(Log(first) + (Log(Last) - Log(first)) * _
(Counter - TopRow) / (BottomRow - TopRow))
Else
ActvSht.Cells(Counter, LeftCol) = _
first + (Last - first) * _
(Counter - TopRow) / (BottomRow - TopRow)
End If
Next Counter
End If
Else
''' Obsolete Else
GoTo ExitRoutine
End If
ExitRoutine:
Set ActvSht = Nothing
Set Slecshun = Nothing
End Sub
'''------------------------------------------------------------
- Jon
