Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Macro que resolva c...
 
Notifications
Clear all

Macro que resolva comparação de dados

 
2024 - VBA & Macros
Post Recente por Rafaelnd 10 anos atrás
3 Posts
2 Usuários
0 Reactions
666 Visualizações
RSS
 Rafaelnd
(@rafaelnd)
Posts: 2
New Member
Topic starter
 

Bom dia pessoal.

Dei uma verificada no fórum pra ver se achava algo relacionado com o meu problema mais não achei. :cry:

Estou fazendo uma planilha no meu serviço que ao importar os dados de um arquivo de texto eu criei algumas macros para edição e para alguns cálculos que me foram exigidos. A sequência das macros são: Editar, Calcular, Separar, Subtotal e Subtotal 2. Até ai tudo bem. Só que para criar subtotais no excel primeiramente tenho que colocar rótulos de linhas.
O problema é que ao tentar criar uma macro para editar a planilha antes do subtotal ela até funciona, mais somente para o arquivo que eu importei devido a quantidade de linhas na planilha.
Na macro subtotal ela ordena a coluna COD de A a Z e a coluna PREÇO do menos para o maior e depois a cada mudança de COD E PREÇO eu insiro um rótulo de linha para não ter problema na hora de criar o subtotal.

EX:

COD MAT.PRIMA PREÇO

3013 30139090 R$ 4,89
3013 30139090 R$ 4,89
3013 30139095 R$ 4,89
3013 30139111 R$ 4,89
3013 30139127 R$ 4,89

COD MAT.PRIMA PREÇO
3015 30154135 R$ 6,14

COD MAT.PRIMA PREÇO
3016 30160105 R$ 3,66
3016 30160190 R$ 3,66

COD MAT.PRIMA PREÇO
3019 30198103 R$ 7,48
3019 30198103 R$ 7,48
3019 30198103 R$ 7,48
3019 30198103 R$ 7,48

Para essa planilha a macro faz corretamente, porém quando coloco outra base de dados em outra planilha ela cola os rótulos de linha na posição errada, pois a quantidade de linhas variam de acordo com o relatório, o que preciso é que a macro dinamize isso ou seja, quando chegar no final de 3013 a R$4,89 ele cole um rótulo de linha independente da posição e independente de quantas linhas tenha a planilha. Já tentei alguma coisa simples com IF, porém sem sucesso. Já que estou iniciando em VBA. Segue abaixo o código da planilha que deu certo.

Na macro abaixo ela irá editar a planilha e colocar os rótulos de linha após as mudanças de COD e PREÇO.
Peço a ajuda de vocês nesse problema porque já não sei o que fazer, não queria ficar modificando as linhas a cada novo relatório. :shock:
Valeu galera. :D

Sub Subtotal()
'
' Subtotal Macro
'
' Atalho do teclado: Ctrl+Shift+T
'
ActiveWindow.SmallScroll Down:=-15
ActiveWindow.Zoom = 90
ActiveWindow.Zoom = 80
ActiveWindow.SmallScroll Down:=-39
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.FormulaR1C1 = "COD"
Range("B1").Select
Columns("A:A").EntireColumn.AutoFit
Range("B1").Select
ActiveCell.FormulaR1C1 = "MAT.PRIMA"
Range("C1").Select
Columns("B:B").EntireColumn.AutoFit
ActiveCell.FormulaR1C1 = "MAT.PARASMO"
Range("D1").Select
Columns("C:C").EntireColumn.AutoFit
ActiveCell.FormulaR1C1 = "DESCRIÇÃO"
Range("E1").Select
Columns("D:D").EntireColumn.AutoFit
Range("E1").Select
ActiveCell.FormulaR1C1 = "PREÇO"
Range("F1").Select
Columns("E:E").ColumnWidth = 9.29
Range("F1").Select
ActiveCell.FormulaR1C1 = "P.LIQUIDO"
Range("G1").Select
Columns("F:F").EntireColumn.AutoFit
Range("G1").Select
ActiveCell.FormulaR1C1 = "P.BRUTO"
Range("H1").Select
Columns("G:G").EntireColumn.AutoFit
Range("H1").Select
ActiveCell.FormulaR1C1 = "A"
Range("I1").Select
Columns("H:H").EntireColumn.AutoFit
Range("I1").Select
ActiveCell.FormulaR1C1 = "B"
Range("J1").Select
Columns("H:H").EntireColumn.AutoFit
Columns("H:H").EntireColumn.AutoFit
ActiveCell.FormulaR1C1 = "C"
Range("K1").Select
Columns("I:I").EntireColumn.AutoFit
Range("K1").Select
ActiveCell.FormulaR1C1 = "QTD.FATOR"
Range("L1").Select
Columns("J:J").EntireColumn.AutoFit
Columns("K:K").EntireColumn.AutoFit
ActiveCell.FormulaR1C1 = "P.LIQ*QTD.FATOR"
Range("M1").Select
Columns("L:L").EntireColumn.AutoFit
Range("M1").Select
ActiveCell.FormulaR1C1 = "P.BRUTO*QTD.FATOR"
Range("N1").Select
Columns("M:M").EntireColumn.AutoFit
Range("A1:M1").Select
Selection.Font.Bold = True
Range("A1").Select

ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range("A2:A260") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

ActiveSheet.Sort.SortFields.Add Key:=Range("E2:E260") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.ActiveSheet.Sort

.SetRange Range("A1:M260").CurrentRegion
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1:M1").Select
Selection.Copy
Rows("17:17").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=39
Rows("59:59").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
Rows("61:61").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
Rows("69:69").Select
Selection.Insert Shift:=xlDown
ActiveWindow.SmallScroll Down:=21
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=15
Rows("94:94").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
Rows("103:103").Select
Selection.Insert Shift:=xlDown
ActiveWindow.SmallScroll Down:=12
Application.CutCopyMode = False
Selection.Copy
Rows("108:108").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
Rows("114:114").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=12
Rows("116:116").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
Rows("119:119").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
Rows("124:124").Select
Selection.Insert Shift:=xlDown
ActiveWindow.SmallScroll Down:=12
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=18
Rows("150:150").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=33
Rows("185:185").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=6
Rows("191:191").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
Rows("193:193").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=33
Rows("224:224").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=24
Rows("248:248").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
Rows("257:257").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=15
Rows("262:262").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
Rows("265:265").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=9
Rows("267:267").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
Rows("269:269").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
Rows("272:272").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
Rows("274:274").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
Rows("276:276").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=9
Rows("278:278").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
Rows("282:282").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
Rows("284:284").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=6
Rows("287:287").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=6
Application.CutCopyMode = False
Range("A290").Select

End sub

 
Postado : 28/05/2015 5:58 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Rafael, o ideal seria você anexar os arquivos com dados reduzidos, e composto da forma que pretende que fique, só pela analise da rotina que colocou fica dificil analisar, a mesma tem muitas instruções que poderiam ser eliminadas e sintetizadas em menos linhas, tipo, tem muitos Range.Select e alguns que pelo que vi não estão servindo para nada, tambem você utiliza muitos EntireColumn.AutoFit para ajustar o tamanho da coluna, e esta é uma das instruções que poderiam ser sintetizadas em apenas uma linha ao final da rotina, eliminando todas e deixando simplesmente assim :

Columns("A:M").EntireColumn.AutoFit - aqui ajustaria as colunas de A até M.

[]s

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

 
Postado : 28/05/2015 6:20 am
 Rafaelnd
(@rafaelnd)
Posts: 2
New Member
Topic starter
 

Desculpe Mauro. Sou novo aqui e nem prestei atenção nesse detalhe. :) Segue em anexo o arquivo. A plan1 é como eu quero que fique o relatório. inclusive as macros foram feitas a partir dela. E na outra plan está somente a base de dados. Sem ter executado as macros ainda.

E sobre as sintetização das instruções é que tenho pouco conhecimento ainda em VBA e quero me aprofundar melhor nesse assunto, também acho terrível essas linhas intermináveis. Mais pra quem está começando a maior preocupação é a funcionalidade. he he he. :)

 
Postado : 28/05/2015 9:19 am
Forum Jump:
  Tópico Anterior
Próximo Tópico