Cfrgtkky

I am trying to get array from range with my own conditions but i cant figure out how to do it.

If table is

    A   B   C  

1   X   X

2       X   X

3   X        

it should come out as

    A   B   C

1:  2   4   0 

2:  0   4   2

3:  1   0   0

or in array {24;042;1}

on B1 and B2 there should be 4 because the formula should count horizontal but also vertical continuum. I tried to use usmanhaq formula but i was not able to modify it so the count resets on every line.
Real size of the table is 7 times 7 cells.

I will use the array with another array (scoreboard which is also 7 times 7 cells, and has numbers 1, 2 or 3 on every cell) using sumproduct and it will give out the points of that player.

I appreciate your efforts on helping out a newbie learner on 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

This is the current style im using to do it with 1 column or row (credit: usmanhaq)

I was waiting for some really pretty recursive algorithm but looks like nobody else was too interested in this problem...

I came up with his quick and dirty algorithm – not that I’m proud of it, it’s rather ugly, but it seems to be working. You should be able to adapt to your needs.

Range B2:H8 is the input range, ranges J2:P8 and B10:H16 were used for debugging, the final output is in range R2:X8.

I would love to see this problem re-done in a pretty, 4- or 5-line recursive code but at the moment I can’t think of it. Hope that helps anyway.

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