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倍。

我将使用sumproduct将这个数组与另一个数组（记分板也是7乘7个单元，每个单元上都有数字1、2或3）一起使用，它将给出该玩家的得分。

感谢您在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列或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

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

1 个答案: