Formel til vb igen

Formlen her er i E16:E1515

- marker cellen med formlen
- Funktioner / makro / Indspil ny makro
- Navngiv makro og tryk OK
- tryk F2 på cellen efterfulgt af ENTER
- stop makro optageren
- kig på koden

Her jeg prøvet men det er ikke lige til når den skal skrive i cellerne og så vil det tage et år.

Resultat indsættes i celle C791. Tilret selv i sidste linje

Sub sammenkæd()
kol = Range("f790:hs790").Columns.Count
arr1 = Range("f790:hs790")
arr2 = Array("F", "Ff", "a", "fril", "S", "bS")
ReDim arr3(UBound(arr2))

For i = 0 To 5
tæl1 = 0
    For j = 1 To kol - 6
    If IsNumeric(arr1(1, j)) And arr1(1, j) <> "" Then
    tæl = tæl + 1
    End If
   
    If arr1(1, j) = arr2(i) Then
    tæl1 = tæl1 + 1
    End If
   
    Next j
arr3(i) = tæl1
Next i

Range("c791") = "V " & tæl / 6 & " F " _
& arr3(0) + arr3(1) + arr3(2) + arr3(3) _
& " S " & arr3(4) + arr3(5)

End Sub

Rettelse: (havde ikke set at den skulle gøre det i alle rækker)

Sub sammenkæd()
Dim arr3(5)
Range("e:e").ClearContents
kol = Range("f790:hs790").Columns.Count
arr1 = Range("f16:hs1515")
arr2 = Array("F", "Ff", "a", "fril", "S", "bS")
ReDim arr4(UBound(arr1), 0)
For k = 0 To 1499

    For i = 0 To 5
        For j = 1 To kol - 6
       
        If IsNumeric(arr1(k + 1, j)) And arr1(k + 1, j) <> "" Then
        tæl = tæl + 1
        End If
   
        If arr1(k + 1, j) = arr2(i) Then
        tæl1 = tæl1 + 1
        End If
   
        Next j
    arr3(i) = tæl1
    tæl1 = 0
    Next i

    arr4(k, 0) = "V " & tæl / 6 & " F " _
    & arr3(0) + arr3(1) + arr3(2) + arr3(3) _
    & " S " & arr3(4) + arr3(5)
   
    tæl = 0
Next k
Range("e16:e1515") = arr4
End Sub

virker takker mrjh

Selvtak <",)