Planilha de Sorteio Excel VBA 2.0

Objetivo: Disponibilizar uma planilha Excel de sorteio que não repita os nomes sorteados e crie uma lista dos nomes já sorteados.

Esta é uma ideia do amigo Cleiton Domingues que me enviou por e-mail, obrigado Cleiton.

Esta planilha auxilia no sorteio de brindes em festas ou reuniões de empresas, bem como qualquer outro tipo de sorteio.

A planilha funciona da seguinte forma:

1. Na planilha Nomes para o sorteio apague todos os nomes que existem nesta lista e coloque um número ao lado de cada nome, pode preencher os dois primeiros números na coluna A somente, em seguida selecionar as células A1 e A2 e dar um duplo clique no cantinho inferior direito desta seleção para que esta lista seja preenchida automaticamente;

2. Agora a planilha já está pronta para funcionar. Clique no botão Limpar sorteados, a planilha irá limpar os dados da sua última utilização, aperte somente quando já houver terminado o sorteio de todos os nomes, pois ele limpará os nomes que já saíram;

3. Clique no botão Sortear, a planilha irá sortear aleatoriamente um nome na sua lista, guardará o nome sorteado na planilha Sorteados e retirará o nome que já saiu;

4. Ao concluir, clique na planilha sorteados aonde você terá todos os nomes que foram sorteados.

Abaixo o código fonte comentado:

'Debugar
'Dim l As Long

'Código principal que realiza o sorteio
Public Sub AleatorioEntreFixo()
    Dim lUltimaLinhaAtiva As Long
    
    Application.Volatile
       
    'Identifica a última célula ativa da lista
    lUltimaLinhaAtiva = Worksheets("Lista").Cells(Worksheets("Lista").Rows.Count, 2).End(xlUp).Row
    
    'Realiza o sorteio fazendo 100 vezes o randômico
    For i = 1 To 100
        Range("A7").FormulaR1C1 = "=VLOOKUP(RANDBETWEEN(1," & lUltimaLinhaAtiva & "),Lista!C[0]:C[1],2,0)"
    Next i
    
    'Debugar
    'Sheets("Nomes para o sorteio").Range("g" & (l + 1)).Value = "'" & Range("A7").FormulaLocal
    'l = l + 1
    
    'Desabilita a atualização de tela para ela não ficar "piscando"
    Application.ScreenUpdating = False
    
    'Copia o nome sorteado para a planilha de sorteados
    Range("A7").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    Range("A7").Select
    Selection.Copy
    Sheets("Sorteados").Select
    
    lUltimaLinhaAtiva = Worksheets("Sorteados").Cells(Worksheets("Sorteados").Rows.Count, 1).End(xlUp).Row
    
    If Range("A1").Value <> "" Then
        Range("A" & lUltimaLinhaAtiva + 1).Select
    Else
        Range("A" & lUltimaLinhaAtiva).Select
    End If
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    'Retira o nome já sorteado
    lsLocalizarApagar
    
    Sheets("Sorteio").Select
    
    'Volta a atualizar a tela
    Application.ScreenUpdating = True
    
End Sub

'Limpa os nomes sorteados
Sub lsLimparSorteados()
    lsCopiaNomesSorteio

    Sheets("Sorteados").Select
    Columns("A:A").Select
    Selection.ClearContents
    Range("A1").Select
    Sheets("Sorteio").Select
    'Debugar
    'l = 0
End Sub

'Copia os nomes do sorteio para a lista, os nomes que são colocados não são apagados
Sub lsCopiaNomesSorteio()
    Sheets("Lista").Select
    Range("A:B").Select
    Selection.ClearContents
    Sheets("Nomes para o sorteio").Select
    Range("A:B").Copy
    Sheets("Lista").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("A1").Select
    Sheets("Sorteio").Select
End Sub

'Localiza, apaga o nome sorteado e reordena os números do sorteio
Sub lsLocalizarApagar()
    On Error Resume Next
    
    Dim lColunaApagar As Long
        
    Range("A7").Copy
    Sheets("Lista").Select
    Columns("B:B").Select
    Sheets("Lista").Select
    Selection.Find(What:=Sheets("Sorteio").Range("A7").Value, After:=ActiveCell, _
                   LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
                   SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    lColunaApagar = ActiveCell.Row
    Rows(lColunaApagar & ":" & lColunaApagar).Select
    Selection.Delete Shift:=xlUp
    
    lsColocaNumeros
    
    Sheets("Sorteio").Select
End Sub

'Coloca os números novamente do sorteio
Sub lsColocaNumeros()
    Dim lUltimaLinhaAtiva As Long
    
    Application.Volatile
       
    lUltimaLinhaAtiva = Worksheets("Lista").Cells(Worksheets("Lista").Rows.Count, 2).End(xlUp).Row

    If lUltimaLinhaAtiva > 1 Then
        ActiveCell.FormulaR1C1 = "1"
        Range("A2").Select
        ActiveCell.FormulaR1C1 = "2"
        Range("A1:A2").Select
        Selection.AutoFill Destination:=Range("A1:A" & lUltimaLinhaAtiva)
        Range("A1:A" & lUltimaLinhaAtiva).Select
        Range("A1").Select
    Else
        ActiveCell.FormulaR1C1 = "1"
    End If
End Sub

DIGITE O SEU EMAIL PARA FAZER O DOWNLOAD DOS ARQUIVOS:

Abraço

Marcos Rieper