Aí está minha sugestão no arquivo anexo, Mineiro.
Com essa macro, as células de J4 a J8 são utilizadas para ordenar os nomes. Por isso, o usuário não deve inserir informação nelas. Além disso, considerei que serão no máximo cinco nomes. Para uma quantidade maior, a macro deve ser adaptada.
Este é o código:
Sub Restringir()
Application.ScreenUpdating = False 'Congela a tela enquanto o código é executado e deixa a macro mais rápida
Dim i, j, resto As Byte 'Declaração de variáveis
'Cria os nomes sem acento à esquerda de cada um na tabela de restrições para possibilitar a ordenação correta destes
Range("J4:J8").FormulaLocal = "=SUBSTITUIR(SUBSTITUIR(SUBSTITUIR(SUBSTITUIR(SUBSTITUIR(SUBSTITUIR(" & _
"SUBSTITUIR(SUBSTITUIR(SUBSTITUIR(SUBSTITUIR(SUBSTITUIR(SUBSTITUIR(K4;""á"";""a"");""à"";""a"");""ã"";" & _
"""a"");""â"";""a"");""é"";""e"");""ê"";""e"");""è"";""e"");""í"";""i"");""ô"";""o"");""ó"";""o"");""õ"";""o"");""ú"";""u"")"
'Copia os nomes (sem acento) da tabela de restrições e cola na tabela amarela e cinza
Range("J4:J8").Copy
Range("D12:H21").PasteSpecial xlPasteValues
'Apaga na tabela amarela e cinza os nomes que tenham restrições e os ordena
For i = 0 To 9
resto = i Mod 2
For j = 0 To 4
If Range("L4").Offset(j, i) > 0 Then
Range("D12").Offset(j + 5 * resto, Int(i / 2)).ClearContents
End If
Next
Range("D12").Offset(5 * resto, Int(i / 2)).Select
Range(Selection, Selection.Offset(4, 0)).Sort key1:=Cells(5 * resto + 12, Int(i / 2) + 4), Header:=xlNo
Next
'Substitui os nomes sem acento por nomes com acento
For j = 0 To 4
Range("D12:H21").Replace What:=Range("J4").Offset(j, 0), Replacement:=Range("K4").Offset(j, 0)
Next
'Apaga os nomes sem acento à esquerda de cada um na tabela de restrições
Range("J4:J8").ClearContents
End Sub
Não se esqueça de marcar o tópico como resolvido se a resposta for satisfatória.
Postado : 14/11/2015 7:14 am