Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Analise de Codigo -...
 
Notifications
Clear all

Analise de Codigo - Abre Arquivo, Deleção Condicional, Copia

 
2024 - VBA & Macros
Post Recente por HugoLopes 11 anos atrás
6 Posts
3 Usuários
0 Reactions
1,129 Visualizações
RSS
 HugoLopes
(@hugolopes)
Posts: 5
Active Member
Topic starter
 

Senhores, sou um pouco nisso e não estou conseguindo resolver o debug do cod a seguir:
[ele não funciona no ultimo passo - o activesheet.paste!]

Sub AtualizaDash_QDC()
Dim lLin As Long
Dim n As Integer

Application.ScreenUpdating = False

'Altere o nome da planilha abaixo:
'Preciso automatizar a forma de escolha do mês
'Preciso incluir a colagem do relatório visão geral
'Atualizar as planilhas dinâmicas
'Alterar o dia para soma acumulada

With Sheets("Dados QDC")
For lLin = .Cells(.Rows.Count, "B").End(xlUp).Row To 2 Step -1
If .Cells(lLin, "B") = Range("b3") Then .Rows(lLin).Delete

'Desafoga os processos pendentes do Windows a cada 100 linhas iteradas:
If lLin Mod 100 = 0 Then DoEvents
Next lLin
End With

Application.ScreenUpdating = True

'Insere duas linhas e marca B3 de amarelo

Rows("3:3").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("B3").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("C3").Select
ActiveCell.FormulaR1C1 = "DIGITE O MÊS CORRENTE"
Range("C4").Select

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Workbooks.Open FileName:= _
"\usaRelatoriosM4UAssinaturasVisaoGeral_CLARO_TODOSOSSERVICOS.xls"

Workbooks.Open FileName:= _
"\usaRelatoriosM4UAssinaturasVisaoGeral_claro_TOS_DiaeMes.xlsm"

' a variável n recebe o número de planilhas no arquivo
n = Sheets.Count

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''' Primeiramente vamos fazer todo o procedimento com a primeira planilha, pois nela há a necessidade de se
'''' agregar as primeiras células que contém o cabeçalho... Depois, se houver mais de uma planilha no relatório,
'''' vamos fazer um for para as outras.

Windows("VisaoGeral_CLARO_TODOSOSSERVICOS.xls").Activate

Worksheets(1).Activate

i = 4
While (Cells(i + 1, 2) <> "")

i = i + 1

Wend

Sheets(1).Copy Before:=Workbooks( _
"VisaoGeral_claro_TOS_DiaeMes.xlsm").Sheets(1)
Cells.Select
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Inserção das colunas dia e mês

Range("A2:K3").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlLTR
.MergeCells = True
End With
Selection.UnMerge
Columns("C:D").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A2:L3").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlLTR
.MergeCells = False
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlLTR
.MergeCells = True
End With

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Range("C4").Select
ActiveCell.FormulaR1C1 = "Mês"
Range("D4").Select
ActiveCell.FormulaR1C1 = "Dia"
Range("C5").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],7)"
Range("D5").Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-2],2)"
Range("C5:D5").Select
Selection.AutoFill Destination:=Range("C5:D" & i)

Columns("B:L").Select

Columns("B:L").EntireColumn.AutoFit

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'um for para fazer o procedimento com as outras planilhas do relatório, caso existam outras planilhas

If (n > 1) Then

For k = 2 To n

Windows("VisaoGeral_CLARO_TODOSOSSERVICOS.xls").Activate

Worksheets(k).Activate

i = 1
While (Cells(i + 1, 2) <> "")

i = i + 1

Wend

Sheets(k).Copy Before:=Workbooks( _
"VisaoGeral_claro_TOS_DiaeMes.xlsm").Sheets(1)
Cells.Select
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Inserção das colunas dia e mês

Columns("C:D").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Range("C1").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],7)"
Range("D1").Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-2],2)"
Range("C1:D1").Select
Selection.AutoFill Destination:=Range("C1:D" & i)

Columns("B:L").Select

Columns("B:L").EntireColumn.AutoFit

Next k

End If

Windows("VisaoGeral_claro_TOS_DiaeMes.xlsm").Activate

Application.DisplayAlerts = False

'deleta a planilha com o nome de "relatório" no arquivo de geração
Sheets("relatório").Select
ActiveWindow.SelectedSheets.Delete

Application.DisplayAlerts = True

'Dim resposta As String
'resposta = MsgBox("Relatório gerado com sucesso.", vbOKOnly)

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Deleta tudo o que não é Quero Descontos

Windows("VisaoGeral_claro_TOS_DiaeMes.xlsm").Activate

With Sheets("Sheet1")
For lLin = .Cells(.Rows.Count, "F").End(xlUp).Row To 2 Step -1
If .Cells(lLin, "F") <> "Quero Descontos" Then .Rows(lLin).Delete

'Desafoga os processos pendentes do Windows a cada 100 linhas iteradas:
If lLin Mod 100 = 0 Then DoEvents
Next lLin
End With

Columns("E:F").Select
Selection.Delete Shift:=xlToLeft

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Copia o relatório e cola no Dashboard do QDC

Windows("VisaoGeral_claro_TOS_DiaeMes.xlsm").Activate
Range("A3").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

Windows("Dashboard_QDC.xlsx").Activate
Range("A5").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste

End Sub

 
Postado : 08/04/2014 3:50 pm
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Hugo, o codigo é um pouco extenso para acertar de primeira, ainda mais sem os modelos para analisar melhor.
Desta forma procurando seguir a logica em suas instruções, se todas estão funcionando e somente se dá o erro na instrução que mencionou, eu arrisco o palpite que o erro é devido a seleção que está fazendo antes da instrução "ActiveSheet.Paste":

Explicando, pelo que entendi só teremos o erro no PASTE, se no endereço a ser colocado não contiver nenhum dado ainda lançado:

Seguindo a logica passo a passo:

'Copia o relatório e cola no Dashboard do QDC

Nas linhas abaixo
Windows("VisaoGeral_claro_TOS_DiaeMes.xlsm").Activate - Ativamos a Janela "VisaoGeral_claro_TOS_DiaeMes.xlsm"
Range("A3").Select - Selecionamos o Range A3

Nas duas linhas seguintes selecionamos as Colunas(A direita) Preenchidas e Linhas Abaixo preenchidas
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy - E copiamos

Windows("Dashboard_QDC.xlsx").Activate - - Ativamos a Janela "Dashboard_QDC.xlsx"
Range("A5").Select - Selecionamos o Range A5

Aqui é que mora o perigo, modo de dizer, mas detalhando:
As duas linhas servem :
Selection.End(xlDown).Select - para ir até a ULTIMA CELULA PREENCHIDA
ActiveCell.Offset(1, 0).Select - E apos ir para uma linha abaixoA

ActiveSheet.Paste - E colarmos o que foi copiado

Até ai sem nenhum problema, acredito que nem precisaria ter escrito tudo ista, então a questão é : O Porque do erro ?
Como eu disse, é somente uma suposição uma vez que não temos os modelos, então temos duas possibilidades :
Ou na aba do arquivo Dashboard_QDC.xlsx que está querendo colar abaixo de A5 não tem nenhum dado, e por isto a instrução "Selection.End(xlDown).Select" posicionou o cursor na ultima celula da planilha tornando sem efeito a seleção de uma abaixo, ou

supondo que foi copiado 10 linhas e na aba a ser colada ter menos linhas o que acarretara o erro por falta de espaço para colar.

Espero que tenha entendido.

[]s

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 08/04/2014 4:30 pm
 HugoLopes
(@hugolopes)
Posts: 5
Active Member
Topic starter
 

Oi Mauro,
muito obrigado pela ajuda.
Eu colei todo o código pq o tempo de execução está muito alto. Queria otimizá-lo mas não sei como e esqueci de falar isso.
Minha leiga hipótese é que a deleção linha a linha, de muitas linha, não é a melhor prática. Falo da seguinte parte:
With Sheets("Sheet1")
For lLin = .Cells(.Rows.Count, "F").End(xlUp).Row To 2 Step -1
If .Cells(lLin, "F") <> "Quero Descontos" Then .Rows(lLin).Delete

'Desafoga os processos pendentes do Windows a cada 100 linhas iteradas:
If lLin Mod 100 = 0 Then DoEvents
Next lLin
End With

 
Postado : 09/04/2014 8:28 am
 Edcronos
(@edcronos)
Posts: 1006
Noble Member
 

para otimizar sua macro
comece por excluir os select

Range("C5:D5").Select
Selection.AutoFill Destination:=Range("C5:D" & i)

Range("C5:D5").AutoFill Destination:=Range("C5:D" & i)

Range("C5").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],7)"

Range("C5").FormulaR1C1 = "=LEFT(RC[-1],7)"

Somente é impossíveis até que alguém faça
A logica está presa na irracionalidade humana, e morta nos que se consideram donos da verdade.

"ALGUM MODERADOR ME EXPULSE DO FÓRUM POR FAVOR"

 
Postado : 09/04/2014 8:47 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Hugo,
Eu me atentei mais a questão do erro, o que eu postei referente ao erro resolveu ?

Sua rotina completa está parecendo que foi construida utilizando o gravador de macros, o que geralmente deixa varias linhas desnecessárias, e alem das dicas do Edcronos podemos otimizar as linhas:

Aqui estamos inserindo duas linhas a partir da linha 3:
Rows("3:3").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Estas 3 instruções podem ser substituidas por:
Rows("3:4").Insert Shift:=xlDown
Para entender a instrução acima temos, "3:4" - Inicio Linha "3" então "3 para 4" temos "duas linhas" considerando a "3", se fossemos adicionar 3 linhas seria "3:5" onde "3 para 5" igual a "3".

Tenha sempre em mente que não precisamos selecionar linhas para executar ações, e tomar cuidado quando utilizamos "ActiveCell".

O tempo é curto, ja estou de saida pro almoço, mas tem varios outros pontos na rotina que daria para otimizar, tipo você está ativando um mesmo arquivo e aba mais de uma vez, mas teria de analisar com mais calma se realmente é necessário, uma vez que podemos referenciar as mesmas deixando em memoria atraves de Variáveis Publicas e só utilizar as mesmas sem precisar ficando ativando e selecionando.

[]s

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 09/04/2014 9:08 am
 HugoLopes
(@hugolopes)
Posts: 5
Active Member
Topic starter
 

Obrigado Edcronos!! Abraços.

Oi Mauro,
resolveu sim! Devo abrir um outro tópico para discutir a otimização?
Abraços.

 
Postado : 09/04/2014 1:22 pm
Forum Jump:
  Tópico Anterior
Próximo Tópico