Как преобразовать Различный массив в Диапазон?
У меня есть 2D массив типа Variant. Размер и значения, которые заполняют массив, сгенерированы на основе данных в рамках рабочего листа. Последующая обработка требуется на этом массиве, основное существо интерполяция нескольких значений. Я использую эту функцию интерполяции (я знаю о Excel эквивалентные функции, но проектное решение было сделано не использовать их). Проблема, которую я имею, что Функция интерполяции требует объекта Диапазона.
Я уже попытался изменить функцию для использования Варианта (r as Variant) аргумент. Следующая строка nR = r.Rows.Count может быть заменен nR = Ubound(r). В то время как это работает, я также хотел бы использовать эту функцию обычно в рамках любого рабочего листа и не изменить функцию всегда.
Sub DTOP()
Dim term_ref() As Variant
' snip '
ReDim term_ref(1 To zeroRange.count, 1 To 2)
' values added to term_ref '
' need to interpolate x1 for calculated y1 '
x1 = Common.Linterp(term_ref, y1)
End Sub
Функция интерполяции
Function Linterp(r As Range, x As Double) As Double
Dim lR As Long, l1 As Long, l2 As Long
Dim nR As Long
nR = r.Rows.Count
' snipped for brevity '
End Function
Как я преобразовываю свой различный массив в оперативной памяти в Диапазон так, чтобы он мог использоваться для интерполировать функции? (не производя к WorkSheet)
Ответ
Короче говоря, ответ - Вы, не может. Объект Диапазона должен сослаться на рабочий лист.
Измененная функция интерполяции проверяет TypeName из аргумента и устанавливает значение nR соответственно. Не самое симпатичное решение.
Как примечание, VarType функционируйте оказался бесполезным в этой ситуации начиная с обоих VarType(Variant()) и VarType(Range) возвращенный то же значение (т.е. vbArray) и не мог использоваться для устранения неоднозначности массива от диапазона
Function Linterp(r As Variant, x As Variant) As Double
Dim lR As Long, l1 As Long, l2 As Long
Dim nR As Long
Dim inputType As String
inputType = TypeName(r)
' Update based on comment from jtolle
If TypeOf r Is Range Then
nR = r.Rows.Count
Else
nR = UBound(r) - LBound(r) 'r.Rows.Count
End If
' ....
End Function
2 ответа
Насколько я знаю, вы не можете создать объект Range, который каким-либо образом не ссылается на расположение вашей книги на листе. Это может быть что-то динамическое, например, функция Named = OFFSET (), но она должна быть где-то привязана к рабочему листу.
Почему бы не изменить функцию интерполяции? Сохраните подпись Linterp как есть, но превратите ее в оболочку для функции, которая интерполирует массив.
Примерно так:
Function Linterp(rng As Range, x As Double) As Double
' R is a two-column range containing known x, known y
' This is now just a wrapper function, extracting the range values into a variant
Linterp = ArrayInterp(rng.Value, x)
End Function
Function ArrayInterp(r As Variant, x As Double) As Double
Dim lR As Long
Dim l1 As Long, l2 As Long
Dim nR As Long
nR = UBound(r) ' assumes arrays are all 1-based
If nR = 1 Then
' code as given would return 0, better would be to either return
' the only y-value we have (assuming it applies for all x values)
' or perhaps to raise an error.
ArrayInterp = r(1, 2)
Exit Function
End If
If x < r(1, 1) Then ' x < xmin, extrapolate'
l1 = 1
l2 = 2
ElseIf x > r(nR, 2) Then ' x > xmax, extrapolate'
l2 = nR
l1 = l2 - 1
Else
' a binary search might be better here if the arrays are large'
For lR = 1 To nR
If r(lR, 1) = x Then ' no need to interpolate if x is a point in the array'
ArrayInterp = r(lR, 2)
Exit Function
ElseIf r(lR, 2) > x Then ' x is between tabulated values, interpolate'
l2 = lR
l1 = lR - 1
Exit For
End If
Next
End If
ArrayInterp = r(l1, 2) _
+ (r(l2, 2) - r(l1, 2)) _
* (x - r(l1, 1)) _
/ (r(l2, 1) - r(l1, 1))
End Function
вот функция для создания диапазона на новом листе. Вы можете изменить эту функцию, добавив еще один параметр диапазона, чтобы задать начальную точку для диапазона ячеек, в котором будет храниться ваш массив.
Сначала введите код как есть и пройдите через Sub Test () с помощью отладчика, чтобы увидеть, что он может для вас сделать ...
Function Array2Range(MyArray() As Variant) As Range
Dim X As Integer, Y As Integer
Dim Idx As Integer, Jdx As Integer
Dim TmpSht As Worksheet, TmpRng As Range, PrevRng As Range
X = UBound(MyArray, 1) - LBound(MyArray, 1)
Y = UBound(MyArray, 2) - LBound(MyArray, 2)
Set PrevRng = Selection
Set TmpSht = ActiveWorkbook.Worksheets.Add
Set TmpRng = TmpSht.[A1]
For Idx = 0 To X
For Jdx = 0 To Y
TmpRng(Idx + 1, Jdx + 1) = MyArray(LBound(MyArray, 1) + Idx, LBound(MyArray, 2) + Jdx)
Next Jdx
Next Idx
Set Array2Range = TmpRng.CurrentRegion
PrevRng.Worksheet.Activate
End Function
Sub Test()
Dim MyR As Range
Dim MyArr(3, 3) As Variant
MyArr(0, 0) = "'000"
MyArr(0, 1) = "'0-1" ' demo correct row/column
MyArr(1, 0) = "'1-0" ' demo correct row/column
MyArr(1, 1) = 111
MyArr(2, 2) = 222
MyArr(3, 3) = 333
Set MyR = Array2Range(MyArr) ' to range
Range2Array MyR, MyOther ' and back
End Sub
РЕДАКТИРОВАТЬ ============= изменен subtest () для демонстрации преобразования обратно в массив и добавлен быстрый и грязный фрагмент кода для преобразования обратного диапазона в массив
Sub Range2Array(MyRange As Range, ByRef MyArr() As Variant)
Dim X As Integer, Y As Integer
Dim Idx As Integer, Jdx As Integer
Dim MyArray() As Variant, PrevRng As Range
X = MyRange.CurrentRegion.Rows.Count - 1
Y = MyRange.CurrentRegion.Columns.Count - 1
ReDim MyArr(X, Y)
For Idx = 0 To X
For Jdx = 0 To Y
MyArr(Idx, Jdx) = MyRange(Idx + 1, Jdx + 1)
Next Jdx
Next Idx
MyRange.Worksheet.Delete
End Sub