Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Organizar dados da ...
 
Notifications
Clear all

Organizar dados da exporta do meu sistema

 
Página 2 / 2
2024 - VBA & Macros
Post Recente por gtsalikis 10 anos atrás
23 Posts
2 Usuários
0 Reactions
1,771 Visualizações
RSS
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Olá pessoal,
Tenho que fazer um controle, onde exporto dados do meu sistema para Excel, mas fica muito bagunçados os dados e demorados para ser organizados manualmente.
Nesta organização devem ser copiado o nome do funcionário em todas as linhas correspondente ao seu apontamento até que apareça outro nome e assim sucessivamente. Os dados estarão na aba "Rel. Tempo.xls" e os dados deverão ser organizados na aba Plan1, conforme layout como exemplo.
Na coluna em destaque na Plan1 de amarelo, terá que converter os minutos da coluna "H" que está separado por ponto em horas decimais, substituindo o ponto por virgula para reconhecer números em uma soma. EX.: 5.45 (5 HORAS E 45 MINUTOS) CONVERTIDO FICA 5.75.

Mais compreensão da necessidade favor verificar o arquivo em anexo.

silvajmp

Cópia de Rel Tempo xls.rar
 
Postado : 15/04/2014 8:04 pm
 gtsalikis
(@gtsalikis)
Posts: 2373
Noble Member
 

Olá, Silva, vamos ver se agora resolvemos, rsrs

Sub Organiza_GT()
'Não atualiza a tela
Application.ScreenUpdating = False

'Definição das variáveis
Dim ws_Origem   As Worksheet
Dim ws_Cópia    As Worksheet
Dim Funcionário As String
Dim i           As Integer 'linhas da planiha original
Dim j           As Integer 'linhas da planilha para onde os dados serão copiados
Dim PL          As Integer 'Primeira Linha
Dim UL          As Integer 'Última Linha
Dim Horas       As Double
Dim Minutos     As Double
Dim Tempo       As Double

'Define as planilhas
Set ws_Origem = Sheets("Rel. Tempo.xls")
Set ws_Cópia = Sheets("Plan1")

'Define a primeira linha com dados que interessam
PL = 10
'Pega a última linha com base na coluna A
UL = ws_Origem.Cells(Rows.Count, "A").End(xlUp).Row
'Define o valor de j para a primeira linha onde os dados serão inseridos
j = 2

'Formata a coluna B como data
ws_Cópia.Columns("B").NumberFormat = "dd/mm/yyyy"
'Formata as colunas F e G como hora
ws_Cópia.Columns("F:G").NumberFormat = "hh:mm"
'Formata as colunas H como texto para inserir o tempo com ponto
ws_Cópia.Columns("H").NumberFormat = "@"

'Faz o loop entre a primeira e a última linha definidas acima, aumentanto de 2 em 2 linhas
For i = PL To UL Step 1
    'Verifica qual o funcionário atual e joga seus dados para a variável Funcionário
    If ws_Origem.Cells(i, "A").Value = "Funcionário:" Then Funcionário = ws_Origem.Cells(i, "B").Value
    'Verifica se é uma data, se for, copia os dados
    If IsDate(ws_Origem.Cells(i, "A").Value) Then
        ws_Cópia.Cells(j, "A").Value = Funcionário
        ws_Cópia.Cells(j, "B").Value = CDate(ws_Origem.Cells(i, "A"))
        ws_Cópia.Cells(j, "C").Value = ws_Origem.Cells(i + 1, "A").Value
        ws_Cópia.Cells(j, "D").Value = ws_Origem.Cells(i + 1, "B").Value
        ws_Cópia.Cells(j, "E").Value = ws_Origem.Cells(i, "B").Value
        ws_Cópia.Cells(j, "F").Value = ws_Origem.Cells(i, "C").Value
        ws_Cópia.Cells(j, "G").Value = ws_Origem.Cells(i, "D").Value
        ws_Cópia.Cells(j, "H").Value = ws_Origem.Cells(i, "E").Value
            'Converte os minutos em decimais
            Tempo = ws_Cópia.Cells(j, "H").Value / 100
                Horas = Int(Tempo)
                Minutos = Tempo - Horas
                Minutos = Round(Minutos / 60 * 100, 2)
            Tempo = Horas + Minutos
        ws_Cópia.Cells(j, "I").Value = Tempo
        'Ao fim das cópias, passa j para o valor da linha seguinte
        j = j + 1
    End If
Next i

'Atualiza a tela
Application.ScreenUpdating = True
End Sub
 
Postado : 20/04/2014 9:27 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Olá gtsalikis e a galera do fórum vou importuna-los novamente, gtsalikis deu certo a macro da postagem anterior, mas apareceu mais uma necessidade, teria como no momento da organização, a macro pegar no nome do funcionário como exemplo 000160 - ANDRE DE SOUZA FIGUEIREDO e extrair somente ANDRE SOUZA, ao invés de copiar da forma original, retirando a numeração "000160 -" e todos que tiverem (DE, DOS, ETC...) entre um nome e outro.
Exemplos:
000160 - ANDRE DE SOUZA FIGUEIREDO = ANDRE SOUZA
000931 - JOAO MARIA DO NASCIMENTO = JOAO MARIA

silvajmp

 
Postado : 20/05/2014 5:31 pm
 gtsalikis
(@gtsalikis)
Posts: 2373
Noble Member
 

Silva, tenta sssim:

Sub Organiza_GT()
'Não atualiza a tela
Application.ScreenUpdating = False

'Definição das variáveis
Dim ws_Origem           As Worksheet
Dim ws_Cópia            As Worksheet
Dim arrFuncionario()    As String
Dim Funcionario         As String
Dim i                   As Integer 'linhas da planiha original
Dim j                   As Integer 'linhas da planilha para onde os dados serão copiados
Dim PL                  As Integer 'Primeira Linha
Dim UL                  As Integer 'Última Linha
Dim Horas               As Double
Dim Minutos             As Double
Dim Tempo               As Double

'Define as planilhas
Set ws_Origem = Sheets("Rel. Tempo.xls")
Set ws_Cópia = Sheets("Plan1")

'Define a primeira linha com dados que interessam
PL = 10
'Pega a última linha com base na coluna A
UL = ws_Origem.Cells(Rows.Count, "A").End(xlUp).Row
'Define o valor de j para a primeira linha onde os dados serão inseridos
j = 2

'Formata a coluna B como data
ws_Cópia.Columns("B").NumberFormat = "dd/mm/yyyy"
'Formata as colunas F e G como hora
ws_Cópia.Columns("F:G").NumberFormat = "hh:mm"
'Formata as colunas H como texto para inserir o tempo com ponto
ws_Cópia.Columns("H").NumberFormat = "@"

'Faz o loop entre a primeira e a última linha definidas acima, aumentanto de 2 em 2 linhas
For i = PL To UL Step 1
    'Verifica qual o funcionário atual e joga seus dados para a variável Funcionário
    If ws_Origem.Cells(i, "A").Value = "Funcionário:" Then arrFuncionario = Split(ws_Origem.Cells(i, "B").Value, " ")
    'Filtra os dados do funcionário
        Funcionario = arrFuncionario(2) & " " & arrFuncionario(3)
    'Verifica se é uma data, se for, copia os dados
    If IsDate(ws_Origem.Cells(i, "A").Value) Then
        ws_Cópia.Cells(j, "A").Value = Funcionario
        ws_Cópia.Cells(j, "B").Value = CDate(ws_Origem.Cells(i, "A"))
        ws_Cópia.Cells(j, "C").Value = ws_Origem.Cells(i + 1, "A").Value
        ws_Cópia.Cells(j, "D").Value = ws_Origem.Cells(i + 1, "B").Value
        ws_Cópia.Cells(j, "E").Value = ws_Origem.Cells(i, "B").Value
        ws_Cópia.Cells(j, "F").Value = ws_Origem.Cells(i, "C").Value
        ws_Cópia.Cells(j, "G").Value = ws_Origem.Cells(i, "D").Value
        ws_Cópia.Cells(j, "H").Value = ws_Origem.Cells(i, "E").Value
            'Converte os minutos em decimais
            Tempo = ws_Cópia.Cells(j, "H").Value / 100
                Horas = Int(Tempo)
                Minutos = Tempo - Horas
                Minutos = Round(Minutos / 60 * 100, 2)
            Tempo = Horas + Minutos
        ws_Cópia.Cells(j, "I").Value = Tempo
        'Ao fim das cópias, passa j para o valor da linha seguinte
        j = j + 1
    End If
Next i

'Atualiza a tela
Application.ScreenUpdating = True
End Sub
 
Postado : 20/05/2014 8:44 pm
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

gtsalikis bom dia, deu certo, porém quando entre os nomes tem algum separador, isso é, os "DOS SANTOS, DA SILVA...", eu preciso que retire também esta ligação dos nomes ficando igual ao exemplo:
000160 - ANDRE DE SOUZA FIGUEIREDO = ANDRE SOUZA

Se possível poder ver isso para mim, caso contrário já me ajudou muito, consigo me virar com esta atividade.

silvajmp

 
Postado : 21/05/2014 5:32 am
 gtsalikis
(@gtsalikis)
Posts: 2373
Noble Member
 

Bom dia, Silva,

Não sei se tem uma forma melhor de fazer iso, então, montei 2 códigos, o primeiro talvez resolva, o segundo é pra resolver, mas tem o lado chato de vc ter q incluir TODAS as palavras atonas nele (o que não é muito legal).

O primeiro, veja que inclui uma condição nele:

If Len(arrFuncionario(3)) <= 3 Then

O que significa que, se o segundo nome tiver 3 ou menos caracteres, ou for um "JR", por exemplo, não vai te dar o resultado esperado, e pode até gerar um erro.

Sub Organiza_GT()
'Não atualiza a tela
Application.ScreenUpdating = False

'Definição das variáveis
Dim ws_Origem           As Worksheet
Dim ws_Cópia            As Worksheet
Dim arrFuncionario()    As String
Dim Funcionario         As String
Dim i                   As Integer 'linhas da planiha original
Dim j                   As Integer 'linhas da planilha para onde os dados serão copiados
Dim PL                  As Integer 'Primeira Linha
Dim UL                  As Integer 'Última Linha
Dim Horas               As Double
Dim Minutos             As Double
Dim Tempo               As Double

'Define as planilhas
Set ws_Origem = Sheets("Rel. Tempo.xls")
Set ws_Cópia = Sheets("Plan1")

'Define a primeira linha com dados que interessam
PL = 10
'Pega a última linha com base na coluna A
UL = ws_Origem.Cells(Rows.Count, "A").End(xlUp).Row
'Define o valor de j para a primeira linha onde os dados serão inseridos
j = 2

'Formata a coluna B como data
ws_Cópia.Columns("B").NumberFormat = "dd/mm/yyyy"
'Formata as colunas F e G como hora
ws_Cópia.Columns("F:G").NumberFormat = "hh:mm"
'Formata as colunas H como texto para inserir o tempo com ponto
ws_Cópia.Columns("H").NumberFormat = "@"

'Faz o loop entre a primeira e a última linha definidas acima, aumentanto de 2 em 2 linhas
For i = PL To UL Step 1
    'Verifica qual o funcionário atual e joga seus dados para a variável Funcionário
    If ws_Origem.Cells(i, "A").Value = "Funcionário:" Then arrFuncionario = Split(ws_Origem.Cells(i, "B").Value, " ")
        'Filtra os dados do funcionário
        'Se o segundo nome tiver 3 ou menos letras, considera como palavra átona e pega o quarto nome
        If Len(arrFuncionario(3)) <= 3 Then
            Funcionario = arrFuncionario(2) & " " & arrFuncionario(4)
        Else
            Funcionario = arrFuncionario(2) & " " & arrFuncionario(3)
        End If
    'Verifica se é uma data, se for, copia os dados
    If IsDate(ws_Origem.Cells(i, "A").Value) Then
        ws_Cópia.Cells(j, "A").Value = Funcionario
        ws_Cópia.Cells(j, "B").Value = CDate(ws_Origem.Cells(i, "A"))
        ws_Cópia.Cells(j, "C").Value = ws_Origem.Cells(i + 1, "A").Value
        ws_Cópia.Cells(j, "D").Value = ws_Origem.Cells(i + 1, "B").Value
        ws_Cópia.Cells(j, "E").Value = ws_Origem.Cells(i, "B").Value
        ws_Cópia.Cells(j, "F").Value = ws_Origem.Cells(i, "C").Value
        ws_Cópia.Cells(j, "G").Value = ws_Origem.Cells(i, "D").Value
        ws_Cópia.Cells(j, "H").Value = ws_Origem.Cells(i, "E").Value
            'Converte os minutos em decimais
            Tempo = ws_Cópia.Cells(j, "H").Value / 100
                Horas = Int(Tempo)
                Minutos = Tempo - Horas
                Minutos = Round(Minutos / 60 * 100, 2)
            Tempo = Horas + Minutos
        ws_Cópia.Cells(j, "I").Value = Tempo
        'Ao fim das cópias, passa j para o valor da linha seguinte
        j = j + 1
    End If
Next i

'Atualiza a tela
Application.ScreenUpdating = True
End Sub

O segundo código, eu incluí m loop que busca TODAS as palavras átonas de um nome, e vc precisa configurar aqui:

ReDim arrAtono(1 to 5)
arrAtono(1) = "DE"
arrAtono(2) = "DA"
arrAtono(3) = "DO"
arrAtono(4) = "DAS"
arrAtono(5) = "DOS"

Veja que, para cada caso, incluí uma um novo número sequencial, e que a linha: ReDim arrAtono(1 to 5) tem o número inicial e final (1 e 5). Se tiverem mais casos, vc vai ter que incluir cada um deles.

Sub Organiza_GT()
'Não atualiza a tela
Application.ScreenUpdating = False

'Definição das variáveis
Dim ws_Origem           As Worksheet
Dim ws_Cópia            As Worksheet
Dim arrFuncionario()    As String
Dim arrAtono()          As String
Dim Funcionario         As String
Dim i                   As Integer 'linhas da planiha original
Dim j                   As Integer 'linhas da planilha para onde os dados serão copiados
Dim x                   As Integer
Dim PL                  As Integer 'Primeira Linha
Dim UL                  As Integer 'Última Linha
Dim Horas               As Double
Dim Minutos             As Double
Dim Tempo               As Double

'Define as planilhas
Set ws_Origem = Sheets("Rel. Tempo.xls")
Set ws_Cópia = Sheets("Plan1")

'Define os elementos átonos que devems ser retirados do meio do nome
ReDim arrAtono(1 to 5)
arrAtono(1) = "DE"
arrAtono(2) = "DA"
arrAtono(3) = "DO"
arrAtono(4) = "DAS"
arrAtono(5) = "DOS"

'Define a primeira linha com dados que interessam
PL = 10
'Pega a última linha com base na coluna A
UL = ws_Origem.Cells(Rows.Count, "A").End(xlUp).Row
'Define o valor de j para a primeira linha onde os dados serão inseridos
j = 2

'Formata a coluna B como data
ws_Cópia.Columns("B").NumberFormat = "dd/mm/yyyy"
'Formata as colunas F e G como hora
ws_Cópia.Columns("F:G").NumberFormat = "hh:mm"
'Formata as colunas H como texto para inserir o tempo com ponto
ws_Cópia.Columns("H").NumberFormat = "@"

'Faz o loop entre a primeira e a última linha definidas acima, aumentanto de 2 em 2 linhas
For i = PL To UL Step 1
    'Verifica qual o funcionário atual e joga seus dados para a variável Funcionário
    If ws_Origem.Cells(i, "A").Value = "Funcionário:" Then arrFuncionario = Split(ws_Origem.Cells(i, "B").Value, " ")
    'Filtra os dados do funcionário
        For x = 1 To UBound(arrAtono)
            If arrFuncionario(3) = arrAtono(x) Then
                Funcionario = arrFuncionario(2) & " " & arrFuncionario(4)
                GoTo salto1
            End If
        Next x
        Funcionario = arrFuncionario(2) & " " & arrFuncionario(3)
salto1:
    'Verifica se é uma data, se for, copia os dados
    If IsDate(ws_Origem.Cells(i, "A").Value) Then
        ws_Cópia.Cells(j, "A").Value = Funcionario
        ws_Cópia.Cells(j, "B").Value = CDate(ws_Origem.Cells(i, "A"))
        ws_Cópia.Cells(j, "C").Value = ws_Origem.Cells(i + 1, "A").Value
        ws_Cópia.Cells(j, "D").Value = ws_Origem.Cells(i + 1, "B").Value
        ws_Cópia.Cells(j, "E").Value = ws_Origem.Cells(i, "B").Value
        ws_Cópia.Cells(j, "F").Value = ws_Origem.Cells(i, "C").Value
        ws_Cópia.Cells(j, "G").Value = ws_Origem.Cells(i, "D").Value
        ws_Cópia.Cells(j, "H").Value = ws_Origem.Cells(i, "E").Value
            'Converte os minutos em decimais
            Tempo = ws_Cópia.Cells(j, "H").Value / 100
                Horas = Int(Tempo)
                Minutos = Tempo - Horas
                Minutos = Round(Minutos / 60 * 100, 2)
            Tempo = Horas + Minutos
        ws_Cópia.Cells(j, "I").Value = Tempo
        'Ao fim das cópias, passa j para o valor da linha seguinte
        j = j + 1
    End If
Next i

'Atualiza a tela
Application.ScreenUpdating = True
End Sub
 
Postado : 21/05/2014 5:57 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Gilmar bom dia, fiz o teste com a segunda opção e deu certo, porém a macro demorou quase 6 minutos para acabar de executar, sei que tem varias condicionais, mas era para demorar isso mesmo? Desconsiderei algumas linhas de dados por não serem do evento desta fase, mas utilizarei mais para frente colocando a macro original, então a macro ficou assim:

Sub Organiza_GT()
'Não atualiza a tela
Application.ScreenUpdating = False

'Definição das variáveis
Dim ws_Origem           As Worksheet
Dim ws_Cópia            As Worksheet
Dim arrFuncionario()    As String
Dim arrAtono()          As String
Dim Funcionario         As String
Dim i                   As Integer 'linhas da planiha original
Dim j                   As Integer 'linhas da planilha para onde os dados serão copiados
Dim x                   As Integer
Dim PL                  As Integer 'Primeira Linha
Dim UL                  As Integer 'Última Linha
Dim Horas               As Double
Dim Minutos             As Double
Dim Tempo               As Double

'Define as planilhas
Set ws_Origem = Sheets("Rel. Tempo.xls")
Set ws_Cópia = Sheets("Dados Org")

'Define os elementos átonos que devems ser retirados do meio do nome
ReDim arrAtono(1 To 5)
arrAtono(1) = "DE"
arrAtono(2) = "DA"
arrAtono(3) = "DO"
arrAtono(4) = "DAS"
arrAtono(5) = "DOS"

'Define a primeira linha com dados que interessam
PL = 10
'Pega a última linha com base na coluna A
UL = ws_Origem.Cells(Rows.Count, "A").End(xlUp).Row
'Define o valor de j para a primeira linha onde os dados serão inseridos
j = 2

'Formata a coluna B como data
ws_Cópia.Columns("B").NumberFormat = "dd/mm/yyyy"
'Formata as colunas C e D como hora
ws_Cópia.Columns("C:D").NumberFormat = "hh:mm"
'Formata as colunas E como texto para inserir o tempo com ponto
ws_Cópia.Columns("E").NumberFormat = "@"

'Faz o loop entre a primeira e a última linha definidas acima, aumentanto de 2 em 2 linhas
For i = PL To UL Step 1
    'Verifica qual o funcionário atual e joga seus dados para a variável Funcionário
    If ws_Origem.Cells(i, "A").Value = "Funcionário:" Then arrFuncionario = Split(ws_Origem.Cells(i, "B").Value, " ")
    'Filtra os dados do funcionário
        For x = 1 To UBound(arrAtono)
            If arrFuncionario(3) = arrAtono(x) Then
                Funcionario = arrFuncionario(2) & " " & arrFuncionario(4)
                GoTo salto1
            End If
        Next x
        Funcionario = arrFuncionario(2) & " " & arrFuncionario(3)
salto1:
    'Verifica se é uma data, se for, copia os dados
    If IsDate(ws_Origem.Cells(i, "A").Value) Then
        ws_Cópia.Cells(j, "A").Value = Funcionario 'Nome do funcionário
        ws_Cópia.Cells(j, "B").Value = CDate(ws_Origem.Cells(i, "A")) 'Data da o.s.
        'ws_Cópia.Cells(j, "C").Value = ws_Origem.Cells(i + 1, "A").Value 'Númro da o.s.
        'ws_Cópia.Cells(j, "D").Value = ws_Origem.Cells(i + 1, "B").Value 'Descrição da o.s.
        'ws_Cópia.Cells(j, "E").Value = ws_Origem.Cells(i, "B").Value 'Tipo de atividade
        'ws_Cópia.Cells(j, "F").Value = ws_Origem.Cells(i, "C").Value 'Hora inicio
        'ws_Cópia.Cells(j, "G").Value = ws_Origem.Cells(i, "D").Value 'Hora fim
        'ws_Cópia.Cells(j, "H").Value = ws_Origem.Cells(i, "E").Value 'Subtração de hora fim com hora inicio
        ws_Cópia.Cells(j, "C").Value = ws_Origem.Cells(i, "C").Value 'Hora inicio
        ws_Cópia.Cells(j, "D").Value = ws_Origem.Cells(i, "D").Value 'Hora fim
        ws_Cópia.Cells(j, "E").Value = ws_Origem.Cells(i, "E").Value 'Subtração de hora fim com hora inicio
        
            'Converte os minutos em decimais
            Tempo = ws_Cópia.Cells(j, "E").Value / 100
                Horas = Int(Tempo)
                Minutos = Tempo - Horas
                Minutos = Round(Minutos / 60 * 100, 2)
            Tempo = Horas + Minutos
        ws_Cópia.Cells(j, "F").Value = Tempo
        'Ao fim das cópias, passa j para o valor da linha seguinte
        j = j + 1
    End If
Next i

'Atualiza a tela
Application.ScreenUpdating = True
End Sub

E se o tempo da demora for considerado devido ao eventos, poderia colocar uma barra de processo da execução da macro?

silva_jmp

 
Postado : 24/05/2014 7:37 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Bom dia!!

Na pesquisa do fórum tem assuntos relacionados a Barra de Progresso.

Leia:
http://www.compuclass.com.br/texto.asp?ID=114
http://www.microsoftexcel.com.br/index. ... resso.html
http://www.ambienteoffice.com.br/office ... progresso/
http://www.exceldoseujeito.com.br/2012/ ... o-parte-2/
http://www.tomasvasquez.com.br/forum/vi ... 4Ch9_ldX1Y
Att

 
Postado : 24/05/2014 7:44 am
 gtsalikis
(@gtsalikis)
Posts: 2373
Noble Member
 

Gilmar bom dia, fiz o teste com a segunda opção e deu certo, porém a macro demorou quase 6 minutos para acabar de executar, sei que tem varias condicionais, mas era para demorar isso mesmo? Desconsiderei algumas linhas de dados por não serem do evento desta fase, mas utilizarei mais para frente colocando a macro original

[...]

E se o tempo da demora for considerado devido ao eventos, poderia colocar uma barra de processo da execução da macro?

silva_jmp

Bom dia, Silva,

eu não entendi muito bem, quando você fala em eventos, está se referindo aos eventos de planilha?
http://msdn.microsoft.com/pt-br/library/office/dn301178(v=office.15).aspx

Se for isso, seria a razão para a demora.

Veja, meu note é uma carroça (quase todo dia tenho vontade de jogar ele na parede). Eu rodei a macro no teu arquivo lá no primeiro post, levou ns 5-6 segundos (contei de cabeça mesmo). Mas eu tinha cometido um engano, deixando lopar mai vezes do que o necessário, então corrigi, e caiu o tempo pra uns 3 segundos. Fiz mais algumas alterações, trocando variáveis integer por long e trocando value por value2, e reduziu o tempo pra uns 2,5 segundos.

Porém, se vc tiver um evento worksheet_change, por exemplo, ele vai ser acionado a cada vez que alguma informação for incluída. Como são 9 alterações na planilha a cada 2 linhas de "Rel. Tempo.xls", que tem mais de 4400 linhas, o evento seria disparado (4400/2) * 9 vezes, ou seja 19.800 vezes.
Se cada vez que o evento rodar, ele gastar 2 centésimos de segundo (0h00min00seg02), isso resulta em 396 segundos, ou seja, 6 minutos e 6 segundos (mais os 5 segundos de execução da macro).

Por isso, inclui informações para desabilitar eventos enquanto a macro executa.

Se não resolver, seria bom vc postar a planilha original.

Abs

Sub Organiza_GT()
'Não atualiza a tela
Application.ScreenUpdating = False
'Desabilita os eventos
Application.EnableEvents = False 'Se vc estiver sando eventos na pasta de trabalho

'Caso algum erro ocorra, reabilita o que foi desabilitado acima e sai da sub
On Error GoTo Habilitar

'Definição das variáveis
Dim ws_Origem           As Worksheet
Dim ws_Cópia            As Worksheet
Dim arrFuncionario()    As String
Dim arrAtono()          As String
Dim Funcionario         As String
Dim i                   As Long 'linhas da planiha original -> Alterado de Integer para Long
Dim j                   As Long 'linhas da planilha para onde os dados serão copiados -> Alterado de Integer para Long
Dim x                   As Long ' -> Alterado de Integer para Long
Dim PL                  As Long 'Primeira Linha -> Alterado de Integer para Long
Dim UL                  As Long 'Última Linha -> Alterado de Integer para Long
Dim Horas               As Double
Dim Minutos             As Double
Dim Tempo               As Double

'Define as planilhas
Set ws_Origem = Sheets("Rel. Tempo.xls")
Set ws_Cópia = Sheets("Plan1")

'Define os elementos átonos que devems ser retirados do meio do nome
ReDim arrAtono(1 To 5)
arrAtono(1) = "DE"
arrAtono(2) = "DA"
arrAtono(3) = "DO"
arrAtono(4) = "DAS"
arrAtono(5) = "DOS"

'Define a primeira linha com dados que interessam
PL = 10
'Pega a última linha com base na coluna A
UL = ws_Origem.Cells(Rows.Count, "A").End(xlUp).Row
'Define o valor de j para a primeira linha onde os dados serão inseridos
j = 2

'Formata a coluna B como data
ws_Cópia.Columns("B").NumberFormat = "dd/mm/yyyy"
'Formata as colunas F e G como hora
ws_Cópia.Columns("F:G").NumberFormat = "hh:mm"
'Formata as colunas H como texto para inserir o tempo com ponto
ws_Cópia.Columns("H").NumberFormat = "@"

'Faz o loop entre a primeira e a última linha definidas acima, aumentanto de 2 em 2 linhas
For i = PL To UL Step 1
    'Verifica qual o funcionário atual e joga seus dados para a variável Funcionário
    If ws_Origem.Cells(i, "A").Value2 = "Funcionário:" Then
        arrFuncionario = Split(ws_Origem.Cells(i, "B").Value2, " ")
        'Filtra os dados do funcionário
        For x = 1 To UBound(arrAtono)
            If arrFuncionario(3) = arrAtono(x) Then
                Funcionario = arrFuncionario(2) & " " & arrFuncionario(4)
                GoTo salto1
            End If
        Next x
        Funcionario = arrFuncionario(2) & " " & arrFuncionario(3)
    End If
salto1:
    'Verifica se é uma data, se for, copia os dados
    If IsDate(ws_Origem.Cells(i, "A").Value2) Then
        ws_Cópia.Cells(j, "A").Value2 = Funcionario
        ws_Cópia.Cells(j, "B").Value2 = CDate(ws_Origem.Cells(i, "A"))
        ws_Cópia.Cells(j, "C").Value2 = ws_Origem.Cells(i + 1, "A").Value2
        ws_Cópia.Cells(j, "D").Value2 = ws_Origem.Cells(i + 1, "B").Value2
        ws_Cópia.Cells(j, "E").Value2 = ws_Origem.Cells(i, "B").Value2
        ws_Cópia.Cells(j, "F").Value2 = ws_Origem.Cells(i, "C").Value2
        ws_Cópia.Cells(j, "G").Value2 = ws_Origem.Cells(i, "D").Value2
        ws_Cópia.Cells(j, "H").Value2 = ws_Origem.Cells(i, "E").Value2
            'Converte os minutos em decimais
            Tempo = ws_Cópia.Cells(j, "H").Value2 / 100
                Horas = Int(Tempo)
                Minutos = Tempo - Horas
                Minutos = Round(Minutos / 60 * 100, 2)
            Tempo = Horas + Minutos
        ws_Cópia.Cells(j, "I").Value2 = Tempo
        'Ao fim das cópias, passa j para o valor da linha seguinte
        j = j + 1
    End If
Next i

Habilitar:
'Atualiza a tela
Application.ScreenUpdating = True
'Reabilita os eventos
Application.EnableEvents = True 'Se vc estiver sando eventos na pasta de trabalho
End Sub
 
Postado : 25/05/2014 9:50 am
Página 2 / 2
Forum Jump:
  Tópico Anterior
Próximo Tópico