Функция VBA для создания массива из таблицы с условиями континуума

Question

Я пытаюсь получить массив из диапазона с моими собственными условиями, но я не могу понять, как это сделать.

Если таблица

    A   B   C  
1   X   X
2       X   X
3   X        

, она должна выглядеть как

    A   B   C
1:  2   4   0 
2:  0   4   2
3:  1   0   0

или в массиве {2 \ 4 \ 0; 0 \ 4 \ 2; 1 \0 \ 0}

на B1 и B2 должно быть 4, потому что формула должна учитывать горизонтальный, но и вертикальный континуум.Я пытался использовать формулу usmanhaq, но я не смог изменить ее, поэтому счетчик сбрасывается в каждой строке.Реальный размер таблицы - 7 × 7 ячеек.

Я буду использовать массив с другим массивом (табло, которое также 7 × 7 ячеек и имеет номера 1, 2 или 3 в каждой ячейке), используя sumproduct ион выдаст очки этого игрока.

Я ценю ваши усилия по оказанию помощи начинающему ученику на vba:)

Function lasker(r As Range, match_chr As String)

Dim check_val
Dim array_value
Dim x As Long
x = r.Cells.Count

Dim number_array() As Long
ReDim number_array(1 To x)


For i = 1 To r.Count

check_value = r.Item(i)

    If (check_value = match_chr) Then
        j = i + 1
        Do While (j <= r.Count) And (check_value = r.Item(j))

            j = j + 1
        Loop

        For k = 1 To j - i
            number_array(i + k - 1) = j - i
        Next k

        i = j - 1
    Else
        number_array(i) = 0
    End If

Next

lasker = number_array


End Function

Это текущий стиль, который я использую, чтобы делать это с1 столбец или строка (кредит: usmanhaq)

Answer 1

Я ждал какой-то действительно довольно рекурсивный алгоритм, но похоже, что никто больше не интересовался этой проблемой ...

Я придумал его быстрый и грязный алгоритм - не то, чтобы я им гордилсяЭто довольно некрасиво, но, похоже, работает.Вы должны быть в состоянии адаптироваться к вашим потребностям.

Диапазон B2: H8 - диапазон ввода, диапазоны J2: P8 и B10: H16 были использованы для отладки, конечный выход находится в диапазоне R2: X8.

Мне бы очень хотелось, чтобы эта проблема была заново решена в симпатичном 4- или 5-строчном рекурсивном коде, но сейчас я не могу об этом думать.Надеюсь, это поможет в любом случае.

Sub AddArrays()

    Dim arrOutH() As Variant
    Dim arrOutV() As Variant
    Dim arrOutT() As Variant
    Dim arrIn() As Variant
    Dim i As Long, j As Long
    Dim rngInput As Range
    Dim side As Long
    Dim cnt As Long, offst As Long
    Dim chr As String

    Set rngin = Range("B2:H8")
    side = Sqr(rngin.Count)
    ReDim arrIn(1 To side, 1 To side)
    ReDim arrOutH(1 To side, 1 To side)
    ReDim arrOutV(1 To side, 1 To side)
    ReDim arrOutT(1 To side, 1 To side)
    arrIn = rngin.Value
    chr = "1"


    j = 1

    For i = 1 To side
        For j = 1 To side
            If arrIn(i, j) = chr Then
                cnt = cnt + 1
                arrOutH(i, j) = arrOutH(i, j) + cnt
            Else
                cnt = 0
            End If
        Next
        cnt = 0
        For x = side - 1 To 1 Step -1
            If arrOutH(i, x) > 0 And arrOutH(i, x) < arrOutH(i, x + 1) Then
                arrOutH(i, x) = arrOutH(i, x + 1)
            End If
        Next
    Next
    'Range("J2:P8") = arrOutH

    For j = 1 To side
        For i = 1 To side
            If arrIn(i, j) = chr Then
                cnt = cnt + 1
                arrOutV(i, j) = arrOutV(i, j) + cnt
            Else
                cnt = 0
            End If
        Next
        cnt = 0
        For x = side - 1 To 1 Step -1
            If arrOutV(x, j) > 0 And arrOutV(x, j) < arrOutV(x + 1, j) Then
                arrOutV(x, j) = arrOutV(x + 1, j)
            End If
        Next
    Next
    'Range("B10:H16") = arrOutV

    For i = 1 To side
        For j = 1 To side
            v = arrOutV(i, j)
            h = arrOutH(i, j)

            If v = 1 And h = 1 Then
                arrOutT(i, j) = 1
            ElseIf (v = 1 Or h = 1) And (v > 1 Or h > 1) Then
                arrOutT(i, j) = Application.Max(v, h)
            Else
                arrOutT(i, j) = v + h
            End If
        Next
    Next

    Range("R2:X8") = arrOutT

End Sub