Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Auto Preenchimento
 
Notifications
Clear all

Auto Preenchimento

 
2024 - VBA & Macros
Post Recente por Wagner Morel 6 anos atrás
12 Posts
3 Usuários
0 Reactions
1,955 Visualizações
RSS
 ghuto_lima
(@ghuto_lima)
Posts: 70
Estimable Member
Topic starter
 

Ola Pessoal, boa tarde a todos.

Estou desenvolvendo uma macro para auto preenchimento de uma formula, porem o final depende dos dados da planilha.
O início é ("AM2") porem o final vai depender dos dados da minha planilha, pode acabar na ("AM50") ou ("AM100") ou ("AM5000")....etc... não estou conseguindo desenvolver a macro, podem me ajudar por favor.

Abaixo a macro.

Range("A1").Select
    Selection.End(xlToRight).Select
    Range("AM1").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    ActiveCell.FormulaR1C1 = "ORDEM PROVA"
    Range("AM2").Select
    ActiveCell.FormulaR1C1 = _
        "=IFERROR(OFFSET(Dados!R1C1,MATCH('inscricoes-1'!RC[-22],cod_prova,0),0),"""")"
    Range("AM2").Select
[color=#FF0000][b]    Selection.AutoFill Destination:=Range("AM2:AM5000")[/b][/color]  (aqui esta o problema, nem sempre vai acabar na "AM5000", pode acabar antes, como falei acima, vai depender dos dados da minha planilha)
    Range("A1").Select

Então tentei a alteração abaixo, mas não deu certo.

Selection.AutoFill Destination:=Range("AM2").End(xlDown)

Muito obrigado.
Abraço.

 
Postado : 25/04/2018 12:23 pm
 Wagner Morel
(@wagner-morel-vidal-nobre)
Posts: 4063
Famed Member
 

ghuto_lima,

Boa tarde!

Coloque, no início da rotina as seguintes linhas:

    Dim UltimaLinha As Long
    
    UltimaLinha = Sheets("Plan1").Cells(Cells.Rows.Count, 39).End(xlUp).Row
    If UltimaLinha < 2 Then UltimaLinha = 2

Na linha onde está o problema relatado, substitua da seguinte forma:

Selection.AutoFill Destination:=Range("AM2:AM" & UltimaLinha)

Solicitamos, por gentileza, das próximas vezes que postar códigos VBA aqui no fórum, utilizar a ferramenta CODE (quinto botão da esquerda para a direita logo acima da caixa de mensagens).

 
Postado : 25/04/2018 12:45 pm
 Wagner Morel
(@wagner-morel-vidal-nobre)
Posts: 4063
Famed Member
 

ghuto_lima,

Boa tarde!

Coloque, no início da rotina as seguintes linhas:

    Dim UltimaLinha As Long
    
    UltimaLinha = Sheets("Plan1").Cells(Cells.Rows.Count, 39).End(xlUp).Row
    If UltimaLinha < 2 Then UltimaLinha = 2

Na linha onde está o problema relatado, substitua da seguinte forma:

Selection.AutoFill Destination:=Range("AM2:AM" & UltimaLinha)

Solicitamos, por gentileza, das próximas vezes que postar códigos VBA aqui no fórum, utilizar a ferramenta CODE (quinto botão da esquerda para a direita logo acima da caixa de mensagens).

 
Postado : 25/04/2018 12:46 pm
 ghuto_lima
(@ghuto_lima)
Posts: 70
Estimable Member
Topic starter
 

Ola Wagner,

Acrescentei, mas da erro de depuração.
Será que acrescentei correto?

 Dim UltimaLinha As Long
   
    UltimaLinha = Sheets("inscricoes-1").Cells(Cells.Rows.Count, 39).End(xlUp).Row
    If UltimaLinha < 2 Then UltimaLinha = 2
    
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    ActiveCell.FormulaR1C1 = "ORDEM PROVA"
    Range("AM2").Select
    ActiveCell.FormulaR1C1 = _
        "=IFERROR(OFFSET(Dados!R1C1,MATCH('inscricoes-1'!RC[-22],cod_prova,0),0),"""")"
    Range("AM2").Select
     
[b][color=#FF0000]    Selection.AutoFill Destination:=Range("AM2:AM" & UltimaLinha)[/color][/b] (<--- o erro é aqui)

Obrigado.

 
Postado : 25/04/2018 1:26 pm
 Wagner Morel
(@wagner-morel-vidal-nobre)
Posts: 4063
Famed Member
 

Preciso ver a sua planilha. Se não puder colocar o arquivo original (grande demais) faça um exemplo (com o mesmo layout do original com 5 linhas por exemplo, compacte e anexe o mesmo aqui.

 
Postado : 25/04/2018 1:33 pm
 ghuto_lima
(@ghuto_lima)
Posts: 70
Estimable Member
Topic starter
 

Ola Wagner,

A planilha esta esta com 192KB mesmo zipada.
Coloquei no Box pode baixar por esse link - https://app.box.com/s/x6vyk12e13g6r3ovhx528sybl7z6i8cg

Ao executar a macro, execute "Formatacao completa"
Como não sei muito de macro, vou fazendo aos poucos e depois junto todas.

Obrigado pela ajuda.

 
Postado : 25/04/2018 1:57 pm
 klarc28
(@klarc28)
Posts: 0
New Member
 
Sub formatacao_completa()
'
' formatacao completa Macro
'

'
    Application.ScreenUpdating = False
    
    Range("AM1").Select
    
    Dim UltimaLinha As Long
   
    UltimaLinha = Sheets("inscricoes-1").Cells(Cells.Rows.Count, 1).End(xlUp).Row '<<<<<<<<<<Alterei aqui, de 39 para 1
    If UltimaLinha < 2 Then UltimaLinha = 2
    
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    ActiveCell.FormulaR1C1 = "ORDEM PROVA"
    Range("AM2").Select
    ActiveCell.FormulaR1C1 = _
        "=IFERROR(OFFSET(Dados!R1C1,MATCH('inscricoes-1'!RC[-22],cod_prova,0),0),"""")"
    Range("AM2").Select
    
    Selection.AutoFill Destination:=Range("AM2:AM" & UltimaLinha)
    
' copiar Macro

Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("AN2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AM2").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Columns("AN:AN").Select
    
' apagar Macro

    Selection.ClearContents
    Range("AM1").Select
    Range("AM1").Select
    
' classificar Macro

    Selection.CurrentRegion.Select
    ActiveWorkbook.Worksheets("inscricoes-1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("inscricoes-1").Sort.SortFields.Add Key:=Range( _
        "U2:U5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("inscricoes-1").Sort.SortFields.Add Key:=Range( _
        "AM2:AM5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("inscricoes-1").Sort.SortFields.Add Key:=Range( _
        "Q2:Q5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("inscricoes-1").Sort
        .SetRange Range("A1:AM5000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
' formatar_tabela
    
    Selection.CurrentRegion.Select
    Range(Selection, Selection.End(xlUp)).Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection.Font
        .Name = "Calibri"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Font.Bold = True
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
    End With
    
' formatacao_condicional

    Range("A2:AM5000").Select
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=$U2:$U5000<>""pago"""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Color = -16776961
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=$U2:$U5000=""liberado"""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.799981688894314
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Range("A1").Select
    ActiveWindow.SmallScroll Down:=-15
    
    Range("A1").Select
    
    Application.ScreenUpdating = True
    
    
End Sub
 
Postado : 26/04/2018 4:45 am
 Wagner Morel
(@wagner-morel-vidal-nobre)
Posts: 4063
Famed Member
 

ghuto_lima,

Bom dia!

Infelizmente, aqui no trabalho não consigo acessar esses sites de compartilhamento de arquivos. Isso é bloqueado na maioria das empresas pois está sujeito a existência de uma quantidade enorme de vírus.

ATENÇÃO: Solicitamos, por gentileza, ao postar código VBA aqui no fórum, utilizar a ferramenta CODE existente logo no início da caixa de mensagens (quinto botão da esquerda para a direita).

 
Postado : 26/04/2018 6:29 am
 klarc28
(@klarc28)
Posts: 0
New Member
 

ghuto_lima,

Teste o código que postei acima e diga se funcionou.

 
Postado : 26/04/2018 6:34 am
 ghuto_lima
(@ghuto_lima)
Posts: 70
Estimable Member
Topic starter
 

Deu certinho Klarc.
Não faço ideia o que você fez, mas esta funcionando.

Obrigado.
Abs.

 
Postado : 27/04/2018 11:04 am
 klarc28
(@klarc28)
Posts: 0
New Member
 
    UltimaLinha = Sheets("inscricoes-1").Cells(Cells.Rows.Count, 1).End(xlUp).Row '<<<<<<<<<<Alterei aqui, de 39 para 1
 
Postado : 27/04/2018 11:25 am
 Wagner Morel
(@wagner-morel-vidal-nobre)
Posts: 4063
Famed Member
 

ghuto_lima,

Boa tarde!

As citações de inteiro teor das mensagens que lhe são enviadas são desnecessárias. Use citação apenas de pequenos trechos das mensagens e se for estritamente necessário ao entendimento da mensagem enviada.

 
Postado : 27/04/2018 12:00 pm
Forum Jump:
  Tópico Anterior
Próximo Tópico