错误13调用函数与循环中的变量数组

时间:2018-01-18 14:38:20

标签: arrays excel vba function parameters

我想从EXCEL表中的Range创建一个二维数组,它有几个未显示(隐藏)的行。首先,我在所有可见行和列的整体大小中创建一个数组。然后我遍历整个范围的Range-Areas并尝试将特定Area的Value-Array分配给目标Array。

这一切都在所有范围区域的循环中运行。扩展Target-Array工作正常十二次(迭代)然后脚本与好的

分手
  

错误13:类型不匹配

@if(session()->has('alert-success')) <div class="alert alert-success"> {{ session()->get('alert-success') }} </div> @endif

功能调用其他十一次正常工作

这是为什么?关于变量数组的大小是否存在一些限制?

我的代码:

这是请求的Sub,它正在调用我的函数......(希望它能让它更清晰一些)。同时感谢提示,我会尝试宣布的一个。)

arr = WriteIntoArray(arr, arArr, targetcell)

Public Sub ProcessIngoingSheetdata(MonthPeriod As Integer, SourceImage As Variant, wsDestination As Worksheet)
' not declared yet - 2018-01-08

Dim rngDestination As Range
Dim arrDestination As Variant
Dim StartAdress(1) As Variant, EndAdress(2) As Variant

Debug.Print "In Sub 'ProcessIngoingSheetdata(MonthPeriod = " & MonthPeriod & "', ...)"

Set rngDestination = SetTargetRange(wsDestination, True) ' die Range für den Zielarray setzen
'rngDestination.Select
'wsDestination.Range("A1").Select

'MultipleRangeToArray
arrDestination = getMultiplerangeAsArray(rngDestination) ' MultipleRangeToArray(rngDestination)
Debug.Print "Boundaries(1) of array Destination: " & LBound(arrDestination, 1) & " to " & UBound(arrDestination, 1)
StartAdress(0) = LBound(arrDestination, 1)
StartAdress(1) = UBound(arrDestination, 1)
Debug.Print "Boundaries(2) of array Destination: " & LBound(arrDestination, 2) & " to " & UBound(arrDestination, 2)
EndAdress(0) = LBound(arrDestination, 2)
EndAdress(1) = UBound(arrDestination, 2)

Debug.Print "arrDestination: " & arrDestination(1, 2) & ", " & arrDestination(28, 2)

End Sub
Function getMultiplerangeAsArray(rngDestination) As Variant()

Dim arr() As Variant, arrExt As Variant, arArr As Variant, arrStart As Variant, r As Long, nr As Long, nc As Long, mar As Long, mac As Long
Dim ar As Range, C As Range, lu As Range, br As Range, cnum As Long, rnum As Long
Dim AbsoluteRowLU As Long, AbsoluteColLU As Long
Dim LastAbsoluteRowLU As Long, LastAbsoluteColLU As Long
Dim RelativeRowLU As Long, RelativeColLU As Long, RelativeRowBR As Long, RelativeColBR As Long
Dim LastRelativeRowLU As Long, LastRelativeColLU As Long, LastRelativeRowBR As Long, LastRelativeColBR As Long
Dim RelativeRowLevelStart As Long, RelativeColLevelStart As Long, RelativeRowLevelEnd As Long, RelativeColLevelEnd As Long
Dim RowHeight As Long, ColWidth As Long, NewRowHeight As Long, NewColWidth As Long
Dim cellDistance As Long
Dim PointerRow As Long
Dim col As Range

' set count of rows to maximum rows of a range-segment
nr = 1
nc = 1

LastRelativeRowBR = 1
LastRelativeColBR = 1

' setting on result-array
arrExt = getExtensionOfMultipleRange(rngDestination)
ReDim arr(arrExt(0), arrExt(1))

For Each ar In rngDestination.Areas

    With ar

        Set lu = .Cells(1)
        Set br = .Cells(.Cells.count)

        If ((Not lu Is Nothing) And (Not br Is Nothing)) Then
            RelativeRowLU = lu.row
            RelativeColLU = lu.column
            RelativeRowBR = br.row
            RelativeColBR = br.column

            AbsoluteRowLU = Range(.Cells(1).Address(0, 0)).row ' Range(.Cells(.Cells.count).Address(0, 0)).row
            AbsoluteColLU = Range(.Cells(1).Address(0, 0)).column

            Debug.Print "Current LU-Cell: '" & AbsoluteRowLU & " / " & AbsoluteColLU & "'."

            cellDistance = ((RelativeRowBR - RelativeRowLU) + 1)
            RowHeight = RowHeight + cellDistance

            cellDistance = ((RelativeColBR - RelativeColLU) + 1)
            ColWidth = ColWidth + cellDistance

        End If

    End With

    'Debug.Print "Left-Upper Cell: " & .Cells(1).Address(0, 0) & " with absolute row " & RelativeRowLU & " / col " & RelativeColLU

    ' check the new absolute-"position" of the current area / array and redim target-array
    If (AbsoluteRowLU > LastAbsoluteRowLU) Then
        RelativeRowLevelStart = AbsoluteRowLU
    End If
    If (AbsoluteColLU > LastAbsoluteColLU) Then
        RelativeColLevelStart = AbsoluteColLU
    End If

    ' to avoid errors also check if the new array is higher or more left (normaly impossible)
    If ((AbsoluteRowLU < AbsoluteRowLU) Or (AbsoluteColLU < LastAbsoluteColLU)) Then
        Debug.Print "getMultiplerangeAsArray(): Substantial error! New array-position is unclear? " & RelativeRowLU & " < " & LastRelativeRowBR & "? " & LastRelativeRowBR & " < " & LastRelativeColBR & " "
        MsgBox "getMultiplerangeAsArray(): Substantial error!", vbCritical
        End
    End If


    arArr = ar.Value
    Debug.Print "#" & nr & ": Größe arArr: (" & LBound(arArr, 1) & " to " & UBound(arArr, 1) & " / " & LBound(arArr, 2) & " to " & UBound(arArr, 2) & ")"

    ' getting now the requested size of the result-array to include the current range-array
    RelativeRowLevelEnd = ((RelativeRowLevelStart + UBound(arArr, 1)) - 1)
    RelativeColLevelEnd = ((RelativeColLevelStart + UBound(arArr, 2)) - 1)
    Debug.Print "The evaluated Row-Range of the result-array is now: " & RelativeRowLevelStart & " to " & RelativeRowLevelEnd
    Debug.Print "The evaluated Col-Range of the result-array is now: " & RelativeColLevelStart & " to " & RelativeColLevelEnd

    ' COMBINE now range-array and result-array
    Debug.Print "TypeName(arr): " & TypeName(arr)
    Debug.Print "TypeName(arArr): " & TypeName(arArr)
    If (IsEmpty(arArr)) Then
        Debug.Print "arArr is empty!"
    End If
    arrStart = Array(RelativeRowLevelStart, RelativeColLevelStart)
    Debug.Print "TypeName(arrStart): " & TypeName(arrStart)
    arr = WriteIntoArray(arr, arArr, arrStart)

    Debug.Print "Fertig combined...."

    ' saving the last relative positions of array for the next loop
    LastRelativeRowLU = RelativeRowLU
    LastRelativeColLU = RelativeColLU
    LastRelativeRowBR = RelativeRowBR
    LastRelativeColBR = RelativeColBR

    ' saving the last absolute positions of array for the next loop
    LastAbsoluteRowLU = AbsoluteRowLU
    LastAbsoluteColLU = AbsoluteColLU

    ' saving the dimensions of the result-array
    RowHeight = NewRowHeight
    ColWidth = NewColWidth

    ' increasing counters
    nr = nr + 1
Next ar

End Function

0 个答案:

没有答案