Bom pessoal, consegui parcialmente usando a rotina abaixo que adaptei com meu pouco conhecimento em VBA, mas me deparei com 2 problemas
1- a rotina só esta fazendo a conversao de uma linha de resultados somente, e preciso que ela corra todas as linhas e apresente os grupos
2- quando faz a conversao esta trazendo 2 ou mais vezes o mesmo grupo(isso acontece pois havera grupos com mais de uma dezena no resultado) e pra mim nao importa a quantidade de dezenas, era só colocar que aquele grupo teve dezenas sorteadas.
se alguem puder ajudar,
grato
Sub Converter()
Dim CompareRange As Variant, x As Variant, y As Variant
Dim k As Integer, j As Integer
k = 8 'Linha Inicial
j = 25 'coluna inicial
Range("y8:am27").ClearContents
Set CompareRange = Range("c2:v2")
For Each x In Range("c5:g5")
For Each y In CompareRange
If x = y Then Cells(k, j) = 1
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c6:g6")
For Each y In CompareRange
If x = y Then Cells(k, j) = 2
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c7:g7")
For Each y In CompareRange
If x = y Then Cells(k, j) = 3
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c8:g8")
For Each y In CompareRange
If x = y Then Cells(k, j) = 4
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c9:g9")
For Each y In CompareRange
If x = y Then Cells(k, j) = 5
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c11:g11")
For Each y In CompareRange
If x = y Then Cells(k, j) = 6
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c12:g12")
For Each y In CompareRange
If x = y Then Cells(k, j) = 7
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c13:g13")
For Each y In CompareRange
If x = y Then Cells(k, j) = 8
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c14:g14")
For Each y In CompareRange
If x = y Then Cells(k, j) = 9
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c15:g15")
For Each y In CompareRange
If x = y Then Cells(k, j) = 10
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c17:g17")
For Each y In CompareRange
If x = y Then Cells(k, j) = 11
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c18:g18")
For Each y In CompareRange
If x = y Then Cells(k, j) = 12
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c19:g19")
For Each y In CompareRange
If x = y Then Cells(k, j) = 13
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c20:g20")
For Each y In CompareRange
If x = y Then Cells(k, j) = 14
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c21:g21")
For Each y In CompareRange
If x = y Then Cells(k, j) = 15
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c23:g23")
For Each y In CompareRange
If x = y Then Cells(k, j) = 16
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c24:g24")
For Each y In CompareRange
If x = y Then Cells(k, j) = 17
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c25:g25")
For Each y In CompareRange
If x = y Then Cells(k, j) = 18
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c26:g26")
For Each y In CompareRange
If x = y Then Cells(k, j) = 19
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
For Each x In Range("c27:g27")
For Each y In CompareRange
If x = y Then Cells(k, j) = 20
Next y
j = j + 1
If j = 19 Then
j = 14
k = k + 1
End If
Next x
MsgBox "Grupos Convertidos"
End Sub
Postado : 08/04/2016 10:10 am