Excel VBA函数从具有连续条件的表创建数组

我试图用我自己的条件从范围内获得数组，但我不知道如何做到这一点

如果桌子是

    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

---

这是我目前使用的一列或一行的方式：usmanhaq

我在等待一些非常漂亮的递归算法，但似乎没有人对这个问题太感兴趣

我想出了他的快速而肮脏的算法——并不是说我为它感到骄傲，它相当丑陋，但它似乎在工作。你应该能够适应你的需要

范围B2:H8是输入范围，范围J2:P8和B10:H16用于调试，最终输出在范围R2:X8内

我很想看到这个问题在一个漂亮的、4行或5行递归代码中重新解决，但目前我想不起来。希望这能有所帮助

---

使用excel工作表中的函数的解决方案可以吗？@W_O_L_如果它被标记为“excel-FORMULA”@W_O_L_如果是的，公式也是有效的选项。除了在只有一个公式时不算数外，它工作得很好。这有点帮助，但现在正是我想要的，我应该在我最初的问题中更具体一些。。桌子上可能有X或Y字母。因此，我应该能够选择chr作为函数中的字符串。正确的规范总是有帮助的。。请现在回顾。它现在工作得很好，我只是把它改成了功能，这样我就可以设置范围和玩家标签了。

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