Olá a todos.
Tenho uma macro relativamente simples no meu trabalho. Não fui eu que fiz e ela é bem antiga.
Sempre funcionou perfeitamente, mas de uns tempos pra cá ela faz cada ação de forma muuuuito lenta.
Ela tem que fazer o seguinte, copiar o nome do funcionário (escolhido de uma lista pré-definida) e criar números sequenciais a partir do último número que foi criado. A quantidade de números a ser criada deve ser informada pelo usuário.
Então, se o último número for 8823 (na linha 15), e foi solicitado gerar 5 números para o João Carlos.
Deverá colar nas linhas acima da linha 15, ficando assim:
linha 15 = 8826 - data - João Carlos
linha 16 = 8825 - data - João Carlos
linha 17 = 8824 - data - João Carlos
Alguém pode me ajudar, deixando a macro mais rápida, mais limpa e sucinta?
Obrigada desde já!
Segue a macro:
Sub Macro_CRIAR_NUMERO_RI()
'
' Macro_CRIAR_NUMERO_RI Macro
' Macro gravada em 3/10/2006 para atribuir número RI
'
' Atalho do teclado: Ctrl+Shift+R
'
Range("D11").Select
ActiveCell.FormulaR1C1 = "=R[4]C[-3]+1"
Range("F11").Select
ActiveCell.FormulaR1C1 = "=C[-2]+R[-3]C[-1]-1"
Range("D11:F11").Select
Selection.Copy
Range("D12").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("F12").Select
Final = ActiveCell.Value
Range("D12").Select
CONTADOR = ActiveCell.Value
Range("A15").Select
While ActiveCell.Value < Final
Rows("15:15").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlDown
Range("A15").Select
ActiveCell.Value = CONTADOR
Range("B8:C8").Select
Selection.Copy
Range("B15").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A15:C15").Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("b15").Select
Application.CutCopyMode = False
Selection.NumberFormat = "dd/mm/yy;@"
CONTADOR = CONTADOR + 1
Range("A15").Select
Wend
Range("D12:F12").Select
Selection.ClearContents
Range("A1").Select
'Protege e salva a planilha
'ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.Save
MsgBox "OS NÚMEROS DE RIs FORAM SALVOS PARA ESTE INSPETOR, EXCLUSIVAMENTE."
End Sub
