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
Lembre-se de AGRADECER aos que te ajudaram, e de marcar o tópico como [Resolvido]
Gente que cuida de gente.
Gilmar
Postado : 21/05/2014 5:57 am