Este fórum está sendo desativado

[lcbispo]

Bom dia pessoal!

Meu codigo abaixo esta demorando muito para gravar, tem como melhorar o meu codigo abaixo:

Sub Gravar_Autorizacao()

Application.ScreenUpdating = False
Dim NAuto As Double
Dim DEmis As Date
Dim DReal As Date
Dim Matri As Double
Dim Nomes As String
Dim Setor As String
Dim Justi As String
Dim VCafe As Double
Dim VRefe As Double
Dim VTran As Double
Dim Total As Double
Dim Pagto As String
Dim Bcohr As String
Dim Indef As String
Dim UltimaCel As Integer

Dim QuantDados As Integer
Dim Linha As Integer

QuantDados = Sheets("Cadastro").Range("F42").End(xlUp).Row
Linha = 20
While Linha < QuantDados + 1

Sheets("Cadastro").Select
NAuto = Range("L13").Value
DEmis = Range("L14").Value
DReal = Range("L15").Value
Matri = Range("E" & Linha).Value
Nomes = Range("F" & Linha).Value
Setor = Range("G" & Linha).Value
Justi = Range("H" & Linha).Value
VCafe = Range("I" & Linha).Value
VRefe = Range("J" & Linha).Value
VTran = Range("K" & Linha).Value
Total = Range("L" & Linha).Value
Pagto = Range("K39").Value
Bcohr = Range("K40").Value
Indef = Range("K41").Value

Sheets("DadosCad").Select

UltimaCel = Range("A65000").End(xlUp).Row + 1
'UltimaCel = Range("A6000").End(xlUp).Row + 1

Range("A" & UltimaCel).Value = NAuto
Range("B" & UltimaCel).Value = DEmis
Range("C" & UltimaCel).Value = DReal
Range("D" & UltimaCel).Value = Matri
Range("E" & UltimaCel).Value = Nomes
Range("F" & UltimaCel).Value = Setor
Range("G" & UltimaCel).Value = Justi
Range("H" & UltimaCel).Value = VCafe
Range("I" & UltimaCel).Value = VRefe
Range("J" & UltimaCel).Value = VTran
Range("K" & UltimaCel).Value = Total
Range("L" & UltimaCel).Value = Pagto
Range("M" & UltimaCel).Value = Bcohr
Range("N" & UltimaCel).Value = Indef

Linha = Linha + 1
Wend

Sheets("Cadastro").Select
Range("L13").Value = Range("L13").Value + 1


Range("F20:F34").ClearContents
Range("H20:H34").Value = ""
Range("K39:K41").Value = ""
Range("L15").Value = ""
MsgBox "Gravado com sucesso"

Application.ScreenUpdating = True
End Sub

Grato.