VBA para distribuição de atividades

[Diogo Muscardi]

Bom dia,

Estou escrevendo um código para distribuir e atribuir atividades igualitariamente entre um grupo de funcionários. O código está distribuindo de forma correta porém ele trava o excel. Ele apenas funciona corretamente quando pauso a execução do macro antes de ele travar o funcionamento do excel. Não estou conseguindo encontrar o erro no código.

Sub AtribuirAtividades()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(5) ' Ajuste o índice se necessário

    Dim ultimaLinha As Long
    ultimaLinha = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

    Dim funcionarios() As Variant
    Dim i As Long

    ' Nomes dos funcionários
    funcionarios = Array("Diogo", "Yanna", "Débora", "Adenilson", "Analista 1", "Analista 2")

    ' Tipos de atividade
    Dim tiposAtividade() As Variant
    ReDim tiposAtividade(1 To 1) ' Inicializar com um tamanho mínimo

    ' Contagem de atividades por tipo
    Dim contagemAtividadesPorTipo As Long
    contagemAtividadesPorTipo = 0

    ' Identificar tipos de atividade e contar a quantidade de cada tipo
    For i = 781 To ultimaLinha
        If Not IsEmpty(ws.Cells(i, 3).Value) Then
            Dim tipoAtividade As String
            tipoAtividade = CStr(ws.Cells(i, 3).Value)
            
            If Not ExisteTipoAtividade(tiposAtividade, tipoAtividade) Then
                contagemAtividadesPorTipo = contagemAtividadesPorTipo + 1
                tiposAtividade(contagemAtividadesPorTipo) = tipoAtividade
                ReDim Preserve tiposAtividade(1 To UBound(tiposAtividade) + 1)
            End If
        End If
    Next i

    ' Calcular a quantidade média de atividades por tipo e por funcionário
    Dim mediaAtividadesPorTipo As Double
    mediaAtividadesPorTipo = Application.WorksheetFunction.RoundUp(contagemAtividadesPorTipo / (UBound(funcionarios) + 1), 0)

    ' Atribuir atividades aos funcionários
    Dim contadorPorTipo As Long
    Dim contadorGeral As Long
    contadorGeral = 0

    Do While contadorGeral < ultimaLinha
        For Each tipo In tiposAtividade
            For Each funcionario In funcionarios
                ' Atribuir atividade ao funcionário correspondente
                For i = 781 To ultimaLinha
                    If ws.Cells(i, 3).Value = tipo Then
                        If ws.Cells(i, 12).Value = "" Then
                            ws.Cells(i, 12).Value = funcionario
                            contadorGeral = contadorGeral + 1
                            contadorPorTipo = contadorPorTipo + 1
                            If contadorPorTipo >= mediaAtividadesPorTipo Then
                                contadorPorTipo = 0
                                Exit For
                            End If
                        End If
                    End If
                Next i
                If contadorGeral >= ultimaLinha Then Exit Do
            Next funcionario
            If contadorGeral >= ultimaLinha Then Exit Do
        Next tipo
    Loop

End Sub

Function ExisteTipoAtividade(ByVal tipos As Variant, ByVal tipo As Variant) As Boolean
    Dim i As Long
    For i = LBound(tipos) To UBound(tipos)
        If tipos(i) = tipo Then
            ExisteTipoAtividade = True
            Exit Function
        End If
    Next i
    ExisteTipoAtividade = False
End Function

[Alyson Ronnan Martins]

Já tive problema assim e eu tive que dividir o processo do código, não deixa um único script fazer tudo o que era necessário.
Mesmo assim olha se esse código tem o mesmo resultado:

 

Sub AtribuirAtividades()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(5) ' Ajuste o índice se necessário

    Dim ultimaLinha As Long
    ultimaLinha = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

    Dim funcionarios() As String
    funcionarios = Array("Diogo", "Yanna", "Débora", "Adenilson", "Analista 1", "Analista 2")

    Dim tiposAtividade As Collection
    Set tiposAtividade = New Collection

    Dim i As Long

    For i = 781 To ultimaLinha
        If Not IsEmpty(ws.Cells(i, 3).Value) Then
            Dim tipoAtividade As String
            tipoAtividade = CStr(ws.Cells(i, 3).Value)

            On Error Resume Next
            tiposAtividade.Add tipoAtividade, tipoAtividade
            On Error GoTo 0
        End If
    Next i

    Dim mediaAtividadesPorTipo As Double
    mediaAtividadesPorTipo = Application.WorksheetFunction.RoundUp(tiposAtividade.Count / (UBound(funcionarios) + 1), 0)

    Dim contadorGeral As Long
    contadorGeral = 0

    Dim tipo As Variant
    For Each tipo In tiposAtividade
        Dim contadorPorTipo As Long
        contadorPorTipo = 0

        For Each funcionario In funcionarios
            For i = 781 To ultimaLinha
                If ws.Cells(i, 3).Value = tipo And ws.Cells(i, 12).Value = "" Then
                    ws.Cells(i, 12).Value = funcionario
                    contadorGeral = contadorGeral + 1
                    contadorPorTipo = contadorPorTipo + 1

                    If contadorPorTipo >= mediaAtividadesPorTipo Then
                        Exit For
                    End If
                End If
            Next i

            If contadorGeral >= ultimaLinha Then Exit For
        Next funcionario

        If contadorGeral >= ultimaLinha Then Exit For
    Next tipo

End Sub

 

@Diogo Muscardi