Subscipt вне диапазона - зацикливание двумерного массива - PullRequest
0 голосов
/ 08 января 2020

Когда запускается следующий код, я получаю

«Нижний индекс вне диапазона»

ошибка в строке GeneraArray(J, K) = ThisWorkbook.Names("rngFinalVal").RefersToRange.Value.

Этот код работает, если я использую другой тип данных для его запуска.

Sub Macro()

    Dim GeneraCount
    Dim NumRows     As Long
    Dim NumCols     As Long

    Dim rInp        As Range
    Dim avInp       As Variant  ' ragged input list
    Dim nCol        As Long     ' # columns in list
    Dim rOut        As Range    ' output range
    Dim iCol        As Long     ' column index
    Dim iRow        As Long     ' row index
    Dim aiCum()     As Long     ' cum count of arrangements from right to left
    Dim aiCnt()     As Long     ' count of items in each column
    Dim iArr        As Long     ' arrangement number
    Dim avOut       As Variant  ' output buffer

    GeneraCount = Application.WorksheetFunction.CountA(ThisWorkbook.Names("rngGenera_Distinct").RefersToRange)
    ThisWorkbook.Names("rngNewCode_Start").RefersToRange.ClearContents

    'LOOPING THROUGH GENERA
    For I = 1 To GeneraCount

        Dim GeneraArray() As Variant
        Dim FinalArr() As Variant

        'Pulling Individual Genera Values From Pivot 2
        Genera = ThisWorkbook.Names("rngGenera_Distinct").RefersToRange.Cells(I, 1)

        'Pushing Genera Value to Excel Sheet for Calculations
        ThisWorkbook.Names("rngSelectedGenera").RefersToRange.Value = Genera

        'Pulling count of subgenera for current genera; this will act as column count of our multidimensional array
        subgeneracount = Application.WorksheetFunction.CountIf(ThisWorkbook.Names("rngSubGenera").RefersToRange, Genera)

        'Pulling max count of skills for current genera; this will act as row count of our multidimensional array
        maxskillcount = ThisWorkbook.Names("rngGeneraSkillMax").RefersToRange.Value
        FinalArray = maxskillcount ^ subgeneracount

        'Refreshing array with dynamic row and column count
        ReDim Preserve GeneraArray(maxskillcount, subgeneracount)
        ReDim Preserve FinalArr(FinalArray)

        For J = 0 To subgeneracount - 1

            ThisWorkbook.Names("rngConcat").RefersToRange.Value = J + 1

            SkillCount = ThisWorkbook.Names("rngConcatCount").RefersToRange.Value

            For K = 0 To SkillCount - 1

                ThisWorkbook.Names("rngSkillID").RefersToRange.Value = K + 1
                GeneraArray(J, K) = ThisWorkbook.Names("rngFinalVal").RefersToRange.Value

            Next K

        Next J

        'PASTING DATA FOR EACH GENUS
        NumRows = J
        NumCols = K

        ThisWorkbook.Sheets("Working Sheet").Activate
        Sheets("Working Sheet").Cells.Clear

        Range("B1").Resize(NumRows, NumCols).Value = Application.Transpose(GeneraArray)

        Cells.Select
        Selection.SpecialCells(xlCellTypeBlanks).Select
        Selection.Delete Shift:=xlUp
        Range("B1").Select

        'CREATING THE COMBINATIONS (copied this from internet)
        Set rInp = Range(Cells(1, 2), Cells(maxskillcount, subgeneracount + 1))

        With rInp
            .Style = "Input"
            avInp = .Value
            nCol = .Columns.Count
            nrows = .Rows.Count
            Set rOut = .Resize(1).Offset(.Rows.Count + 1)
            Range(rOut.Offset(-1, -1), Cells(Rows.Count, Columns.Count)).Clear
        End With

        ReDim aiCum(1 To nCol + 1)
        ReDim aiCnt(1 To nCol)
        aiCum(nCol + 1) = 1

        For iCol = nCol To 1 Step -1
            FilledRow = 0
            For iRow = 1 To UBound(avInp, 1)
                If IsEmpty(avInp(iRow, iCol)) Then FilledRow = FilledRow Else FilledRow = FilledRow + 1
                aiCnt(iCol) = FilledRow
            Next iRow
            Cum = aiCnt(iCol) * aiCum(iCol + 1)
            aiCum(iCol) = aiCnt(iCol) * aiCum(iCol + 1)
        Next iCol

        ReDim avOut(1 To aiCum(1), 1 To nCol)
        For iArr = 1 To aiCum(1)
            For iCol = 1 To nCol
                avOut(iArr, iCol) = avInp((Int((iArr - 1) * aiCnt(iCol) / aiCum(iCol))) Mod aiCnt(iCol) + 1, iCol)
            Next iCol
        Next iArr

        With rOut.Resize(aiCum(1), nCol)
            .NumberFormat = "@"
            .Value = avOut
            .Cells(1, 0).Value = 1
            .Cells(2, 0).Value = 2
            .Cells(1, 0).Resize(2).AutoFill .Columns(0)
        End With

    'CREATING FINAL VALUES AND PASTING THEM IN "WORKIING SHEET FINAL"

    shtCalc.Range("A1").Select
    Selection.End(xlDown).Select
    Selection.End(xlToRight).Select
    Selection.Offset(0, 1).Select

    ActiveCell.FormulaR1C1 = "=TEXTJOIN("", "",TRUE,RC[-3]:RC[-1])"
    Selection.Offset(0, -1).Select
    Selection.End(xlDown).Select
    Selection.Offset(0, 1).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.FillDown
    Selection.Copy
    ThisWorkbook.Names("rngNewCode_Start").RefersToRange.PasteSpecial xlPasteValues
    Application.CutCopyMode = False

    Next I

End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...