A tabela da esquerda contém todos as sequências possíveis de 20 números unidos 3 a 3. A da direita não deveria ter todos as sequências de 20 números unidos 15 a 15? Se sim a da direita está incompleta.
O código abaixo faz a contagem para qualquer quantidade de números na tabela da esquerda (2, 3, 4, etc.). Adotei as seguintes premissas:
1 - Haverá apenas uma coluna entre a tabela da esquerda e a da direita.
2 - A tabela da direita sempre terá 15 colunas.
3 - O espaço à direita da tabela de 15 colunas estará sempre vazio.
4 - A tabela da esquerda sempre se iniciará na coluna C.
5 - Ambas tabelas se iniciarão na terceira linha.
Sub contar()
Dim lin1, lin2, i, n As Integer
Dim criterios As String
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
n = Range("C3", Range("C3").End(xlToRight)).Count
lin1 = Range("P1048576").End(xlUp).Row
lin2 = Range("D1048576").End(xlUp).Row
criterios = ""
For i = 1 To n - 1
criterios = criterios & "RC[-" & i & "]>RC[-" & i + 1 & "],"
Next
If n > 2 Then
criterios = "AND(" & Mid(criterios, 1, Len(criterios) - 1) & ")"
Else
criterios = Mid(criterios, 1, Len(criterios) - 1)
End If
For i = 3 To lin2
Range(Cells(3, 22 + n), Cells(lin1, 22 + 2 * n - 2)).FormulaR1C1 = _
"=IFERROR(MATCH(VALUE(R" & i & "C[-" & n + 19 & "]),RC" & n + 6 & ":RC" & n + 20 & ",0),RC[1]+1)"
Range(Cells(3, 22 + 2 * n - 1), Cells(lin1, 22 + 2 * n - 1)).FormulaR1C1 = _
"=IFERROR(MATCH(VALUE(R" & i & "C[-" & n + 19 & "]),RC" & n + 6 & ":RC" & n + 20 & ",0),0)"
Range(Cells(3, 22 + 2 * n), Cells(lin1, 22 + 2 * n)).FormulaR1C1 = "=IF(" & criterios & ",1,0)"
Cells(3, 22 + 2 * n).Select
Cells(i, n + 4) = Application.WorksheetFunction.Sum(Range(Selection, Selection.End(xlDown)))
Application.StatusBar = Int(i / lin2 * 100) & "%"
Next
Range(Cells(, 22 + n), Cells(, 22 + 2 * n)).EntireColumn.Delete
Application.StatusBar = False
End Sub
Não se esqueça de marcar o tópico como resolvido se a resposta for satisfatória.
Postado : 29/11/2015 3:36 pm