MACRO PARA ORGANIZAR RELATÓRIO
Olá pessoal, sou iniciante Vb Excel, preciso organizar um relatório exportado do sistema da empresa, que vem uma verdadeira 
, estou usando o código abaixo, mas não ficou 100% o resultado, por 2 motivos:
1 - Na exportação, a descrição de cada atividade, dependendo do número de caracteres da descrição, vem dividido em 1, 2 ou mais linhas, na macro abaixo não coloquei nenhuma condicional para concatenar as descrições que vem entre os números das ordens de serviço ex.: 84484-1 / 84485-1, e é isso que eu não consegui fazer.
2 - Outra coisa e que na macro abaixo em algum momento de sua execução, não sei se é por alguma condicional, esta deletando linhas, deixando a aba Rel_Org com dados incompletos.
Pessoal aceito outras alternativas de organizar este relatório, preciso com urgência.
Desde já
agradeço.
jsilva
http://www.4shared.com/file/f_7dzzehce/Relatrio.html
, estou usando o código abaixo, mas não ficou 100% o resultado, por 2 motivos:1 - Na exportação, a descrição de cada atividade, dependendo do número de caracteres da descrição, vem dividido em 1, 2 ou mais linhas, na macro abaixo não coloquei nenhuma condicional para concatenar as descrições que vem entre os números das ordens de serviço ex.: 84484-1 / 84485-1, e é isso que eu não consegui fazer.
2 - Outra coisa e que na macro abaixo em algum momento de sua execução, não sei se é por alguma condicional, esta deletando linhas, deixando a aba Rel_Org com dados incompletos.
Pessoal aceito outras alternativas de organizar este relatório, preciso com urgência.
Sub arrumar()
Application.ScreenUpdating = False
Dim EQUIPE As String
Dim i As Long
Dim UL As Long
Sheets([Ô]Rel_Org[Ô]).Select
Cells.Select
Selection.ClearContents
Sheets([Ô]Rel_Ori[Ô]).Select
Cells.Select
Selection.Copy
Sheets([Ô]Rel_Org[Ô]).Select
Cells.Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range([Ô]A1[Ô]).Select
Rows([Ô]1:11[Ô]).Delete
Columns(1).Insert
Cells(1, [Ô]A[Ô]).Value2 = [Ô]EQUIPE:[Ô]
Cells(1, [Ô]M[Ô]).Value2 = [Ô]Prevista[Ô]
UL = Cells(Rows.Count, 2).End(xlUp).Row
For i = 2 To UL
If Cells(i, [Ô]B[Ô]).Value2 = [Ô]EQUIPE:[Ô] Then
EQUIPE = Cells(i, [Ô]C[Ô]).Value2
Rows(i).Delete
End If
If Cells(i, [Ô]E[Ô]).Value2 = [Ô][Ô] _
Or Cells(i, [Ô]E[Ô]).Value2 = [Ô]Eqpto[Ô] Then
Rows(i).Delete
i = i - 1
Else
Cells(i, [Ô]A[Ô]).Value2 = EQUIPE
Range(Cells(i, [Ô]K[Ô]), Cells(i, [Ô]M[Ô])).Value2 = Range(Cells(i, [Ô]I[Ô]), Cells(i, [Ô]K[Ô])).Value2
Cells(i, [Ô]J[Ô]).Value2 = Cells(i + 1, [Ô]C[Ô]).Value2
Cells(i, [Ô]I[Ô]).ClearContents
Range(Cells(i, [Ô]D[Ô]), Cells(i, [Ô]G[Ô])).Value2 = Range(Cells(i, [Ô]C[Ô]), Cells(i, [Ô]F[Ô])).Value2
Cells(i, [Ô]C[Ô]).Value2 = Cells(i + 1, [Ô]B[Ô]).Value2 & Cells(i + 2, [Ô]B[Ô]).Value2
Rows(i + 1 & [Ô]:[Ô] & i + 2).Delete
End If
UL = Cells(Rows.Count, 2).End(xlUp).Row
If i + 1 >= UL Then Exit For
Next i
Range(Cells(1, 1), Cells(UL, [Ô]M[Ô])).ClearFormats
Range(Cells(1, 1), Cells(1, [Ô]M[Ô])).Font.Bold = True
Range(Cells(1, 1), Cells(UL, 1)).Font.Bold = True
With Range(Cells(1, 1), Cells(UL, [Ô]M[Ô])).Font
.Name = [Ô]Arial[Ô]
.Size = 7
End With
Range(Cells(2, [Ô]F[Ô]), Cells(UL, [Ô]I[Ô])).NumberFormat = [Ô]dd/mm[Ô]
Range(Cells(1, 1), Cells(UL, [Ô]M[Ô])).HorizontalAlignment = xlCenter
Range(Cells(1, 1), Cells(UL, 1)).HorizontalAlignment = xlLeft
Range(Cells(1, 3), Cells(UL, 3)).HorizontalAlignment = xlLeft
Range(Cells(1, 1), Cells(UL, [Ô]M[Ô])).Columns.AutoFit
End Sub Desde já
agradeço.jsilva
http://www.4shared.com/file/f_7dzzehce/Relatrio.html
JSILVA,
1 - Para concatenar as descrições, você precisa saber qual descrição é continuação de qual. Por exemplo. como você sabe que a [Ô]84485-1[Ô] é continuação da [Ô]84484-1 / 84485-1[Ô]?
2 - Você precisa depurar um arquivo pequeno que já viu dar este problema. Existe também um linha [Ô]Rows(i).Delete[Ô] no código...
[][ô]s,
Tunusat.
1 - Para concatenar as descrições, você precisa saber qual descrição é continuação de qual. Por exemplo. como você sabe que a [Ô]84485-1[Ô] é continuação da [Ô]84484-1 / 84485-1[Ô]?
2 - Você precisa depurar um arquivo pequeno que já viu dar este problema. Existe também um linha [Ô]Rows(i).Delete[Ô] no código...
[][ô]s,
Tunusat.
Tunusat boa noite, a descrição esta sempre abaixo do número da ordem, isto é, toda descrição que esta abaixo da os 84484-1 pertence a ela, a descrição que esta abaixo da os 84485-1 pertence a ela.
Jsilva,
Me passa no email mitsueda@ig.com.br
Um modelo do arquivo de texto e um Excel com resultado final da maneira que vc quer.
Abraço
Me passa no email mitsueda@ig.com.br
Um modelo do arquivo de texto e um Excel com resultado final da maneira que vc quer.
Abraço
Fiz o código com base no seu arquivo e ficou conforme segue:
Sub arrumar()
Dim shtOrigem As Worksheet
Dim shtDestino As Worksheet
Dim lngUltLinha As Long
Dim i, x, y As Integer
Dim strEquipe As String
Dim strTexto As String
Dim fCheck As Boolean
[ô]Estabelecendo quais as planilhas serão utilizadas
[ô]Caso altere o nome das planilha será necessario alterar os nomes entre aspas abaixo
Set shtOrigem = ThisWorkbook.Sheets([Ô]Rel_Ori[Ô])
Set shtDestino = ThisWorkbook.Sheets([Ô]Rel_Org[Ô])
[ô]Limpando a area de dados antes de iniciar o tratamento de dados
shtDestino.Range([Ô]A2:M1048576[Ô]).ClearContents
[ô]Capturando a ultima linha preenchida com base na planilha original e coluna A
lngUltLinha = shtOrigem.Range([Ô]A1048576[Ô]).End(xlUp).Row
[ô]Variavel que será incrementada indicando a quantidade de registros e/ou linhas
i = 2
[ô]Iniciando a leitura de dados por repetição até a ultima linha preenchida
For x = 1 To lngUltLinha
With shtOrigem
If .Cells(x, 1).Value = [Ô]EQUIPE:[Ô] Then _
strEquipe = .Cells(x, 2).Value
If VBA.Mid(VBA.Trim(.Cells(x, 1).Value), 6, 1) = [Ô]-[Ô] Then
shtDestino.Cells(i, 1).Value = strEquipe
shtDestino.Cells(i, 2).Value = .Cells(x, 1).Value
[ô]Parte do codigo que existe a duvida utilizando seu criterio logico
strTexto = .Cells(x + 1, 1).Value
fCheck = False
y = 2
[ô]Executando um laço de repetição
Do Until fCheck [ô]verificando quando a variavel será verdadeira
[ô]Verificando se a proxima linha entra em alguma das relações de fim de relatorio
If VBA.Left(VBA.Trim(.Cells(x + y, 1).Value), 6) = [Ô]FMIREL[Ô] _
Or VBA.Left(VBA.Right(VBA.Trim(.Cells(x + y, 1).Value), 3), 1) = [Ô],[Ô] _
Or VBA.Mid(VBA.Trim(.Cells(x + y, 1).Value), 6, 1) = [Ô]-[Ô] Then
fCheck = True
Else
strTexto = strTexto & .Cells(x + y, 1).Value
End If
y = y + 1
Loop
shtDestino.Cells(i, 3).Value = strTexto
[ô]*******************************************************************
shtDestino.Cells(i, 4).Value = .Cells(x, 2).Value
shtDestino.Cells(i, 5).Value = .Cells(x, 3).Value
shtDestino.Cells(i, 6).Value = .Cells(x, 4).Value
shtDestino.Cells(i, 7).Value = .Cells(x, 5).Value
shtDestino.Cells(i, 8).Value = .Cells(x, 6).Value
shtDestino.Cells(i, 9).Value = .Cells(x, 7).Value
shtDestino.Cells(i, 10).Value = .Cells(x + 1, 2).Value
shtDestino.Cells(i, 11).Value = .Cells(x, 8).Value
shtDestino.Cells(i, 12).Value = .Cells(x, 9).Value
shtDestino.Cells(i, 13).Value = .Cells(x, 10).Value
[ô]Incremento de linha
i = i + 1
End If
End With
Next
MsgBox [Ô]Finalizado![Ô]
Set shtOrigem = Nothing
Set shtDestino = Nothing
End Sub
Sub arrumar()
Dim shtOrigem As Worksheet
Dim shtDestino As Worksheet
Dim lngUltLinha As Long
Dim i, x, y As Integer
Dim strEquipe As String
Dim strTexto As String
Dim fCheck As Boolean
[ô]Estabelecendo quais as planilhas serão utilizadas
[ô]Caso altere o nome das planilha será necessario alterar os nomes entre aspas abaixo
Set shtOrigem = ThisWorkbook.Sheets([Ô]Rel_Ori[Ô])
Set shtDestino = ThisWorkbook.Sheets([Ô]Rel_Org[Ô])
[ô]Limpando a area de dados antes de iniciar o tratamento de dados
shtDestino.Range([Ô]A2:M1048576[Ô]).ClearContents
[ô]Capturando a ultima linha preenchida com base na planilha original e coluna A
lngUltLinha = shtOrigem.Range([Ô]A1048576[Ô]).End(xlUp).Row
[ô]Variavel que será incrementada indicando a quantidade de registros e/ou linhas
i = 2
[ô]Iniciando a leitura de dados por repetição até a ultima linha preenchida
For x = 1 To lngUltLinha
With shtOrigem
If .Cells(x, 1).Value = [Ô]EQUIPE:[Ô] Then _
strEquipe = .Cells(x, 2).Value
If VBA.Mid(VBA.Trim(.Cells(x, 1).Value), 6, 1) = [Ô]-[Ô] Then
shtDestino.Cells(i, 1).Value = strEquipe
shtDestino.Cells(i, 2).Value = .Cells(x, 1).Value
[ô]Parte do codigo que existe a duvida utilizando seu criterio logico
strTexto = .Cells(x + 1, 1).Value
fCheck = False
y = 2
[ô]Executando um laço de repetição
Do Until fCheck [ô]verificando quando a variavel será verdadeira
[ô]Verificando se a proxima linha entra em alguma das relações de fim de relatorio
If VBA.Left(VBA.Trim(.Cells(x + y, 1).Value), 6) = [Ô]FMIREL[Ô] _
Or VBA.Left(VBA.Right(VBA.Trim(.Cells(x + y, 1).Value), 3), 1) = [Ô],[Ô] _
Or VBA.Mid(VBA.Trim(.Cells(x + y, 1).Value), 6, 1) = [Ô]-[Ô] Then
fCheck = True
Else
strTexto = strTexto & .Cells(x + y, 1).Value
End If
y = y + 1
Loop
shtDestino.Cells(i, 3).Value = strTexto
[ô]*******************************************************************
shtDestino.Cells(i, 4).Value = .Cells(x, 2).Value
shtDestino.Cells(i, 5).Value = .Cells(x, 3).Value
shtDestino.Cells(i, 6).Value = .Cells(x, 4).Value
shtDestino.Cells(i, 7).Value = .Cells(x, 5).Value
shtDestino.Cells(i, 8).Value = .Cells(x, 6).Value
shtDestino.Cells(i, 9).Value = .Cells(x, 7).Value
shtDestino.Cells(i, 10).Value = .Cells(x + 1, 2).Value
shtDestino.Cells(i, 11).Value = .Cells(x, 8).Value
shtDestino.Cells(i, 12).Value = .Cells(x, 9).Value
shtDestino.Cells(i, 13).Value = .Cells(x, 10).Value
[ô]Incremento de linha
i = i + 1
End If
End With
Next
MsgBox [Ô]Finalizado![Ô]
Set shtOrigem = Nothing
Set shtDestino = Nothing
End Sub
Fabio deu certo com a ultima revisão.
jsilva
Option Explicit
Private module
Sub arrumar()
Dim shtOrigem As Worksheet
Dim shtDestino As Worksheet
Dim lngUltLinha As Long
Dim i, x, y As Integer
Dim strEquipe As String
Dim strTexto As String
Dim fCheck As Boolean
[ô]Desabilitando atualização de tela
Application.ScreenUpdating = False
[ô]Desabilitando os calculos automaticos
Application.Calculation = xlCalculationManual
[ô]Estabelecendo quais as planilhas serão utilizadas
[ô]Caso altere o nome das planilha será necessario alterar os nomes entre aspas abaixo
Set shtOrigem = ThisWorkbook.Sheets([Ô]Rel_Ori[Ô])
Set shtDestino = ThisWorkbook.Sheets([Ô]Rel_Org[Ô])
[ô]Limpando a area de dados antes de iniciar o tratamento de dados
shtDestino.Range([Ô]A2:M1048576[Ô]).ClearContents
[ô]Capturando a ultima linha preenchida com base na planilha original e coluna A
lngUltLinha = shtOrigem.Range([Ô]A1048576[Ô]).End(xlUp).Row
[ô]Variavel que será incrementada indicando a quantidade de registros e/ou linhas
i = 2
[ô]Formatando as colunas para texto
shtDestino.Range([Ô]F2:I1048576[Ô]).NumberFormat = [Ô]@[Ô]
[ô]Iniciando a leitura de dados por repetição até a ultima linha preenchida
For x = 1 To lngUltLinha
With shtOrigem
If .Cells(x, 1).Value = [Ô]EQUIPE:[Ô] Then _
strEquipe = .Cells(x, 2).Value
If VBA.Mid(VBA.Trim(.Cells(x, 1).Value), 6, 1) = [Ô]-[Ô] Then
shtDestino.Cells(i, 1).Value = strEquipe
shtDestino.Cells(i, 2).Value = .Cells(x, 1).Value
[ô]Parte do codigo que existe a duvida utilizando seu criterio logico
strTexto = .Cells(x + 1, 1).Value
fCheck = False
y = 2
[ô]Executando um laço de repetição
Do Until fCheck [ô]verificando quando a variavel será verdadeira
[ô]Verificando se a proxima linha entra em alguma das relações de fim de relatorio
If VBA.Left(VBA.Trim(.Cells(x + y, 1).Value), 6) = [Ô]FMIREL[Ô] _
Or VBA.Left(VBA.Right(VBA.Trim(.Cells(x + y, 1).Value), 3), 1) = [Ô],[Ô] _
Or VBA.Mid(VBA.Trim(.Cells(x + y, 1).Value), 6, 1) = [Ô]-[Ô] Then
fCheck = True
Else
strTexto = strTexto & .Cells(x + y, 1).Value
End If
y = y + 1
Loop
shtDestino.Cells(i, 3).Value = strTexto
[ô]*******************************************************************
shtDestino.Cells(i, 4).Value = .Cells(x, 2).Value
shtDestino.Cells(i, 5).Value = .Cells(x, 3).Value
shtDestino.Cells(i, 6).Value = .Cells(x, 4).Value
shtDestino.Cells(i, 7).Value = .Cells(x, 5).Value
shtDestino.Cells(i, 8).Value = .Cells(x, 6).Value
shtDestino.Cells(i, 9).Value = .Cells(x, 7).Value
shtDestino.Cells(i, 10).Value = .Cells(x + 1, 2).Value
On Error Resume Next
shtDestino.Cells(i, 11).Value = VBA.CDbl(.Cells(x, 8).Value)
shtDestino.Cells(i, 12).Value = VBA.CDbl(.Cells(x, 9).Value)
shtDestino.Cells(i, 13).Value = VBA.CDbl(.Cells(x, 10).Value)
On Error GoTo 0
[ô]Incremento de linha
i = i + 1
End If
End With
Next
MsgBox [Ô]Finalizado![Ô]
[ô]Habilitando atualização de tela
Application.ScreenUpdating = True
[ô]Habilitando os calculos automaticos
Application.Calculation = xlCalculationAutomatic
Set shtOrigem = Nothing
Set shtDestino = Nothing
End Sub
jsilva
Tópico encerrado , respostas não são mais permitidas