Botão "GRAVAR"

Formulários

Post Recente por wellrock 10 anos atrás

3 Posts

2 Usuários

0 Reactions

1,120 Visualizações

RSS

wellrock

(@wellrock)

Posts: 4

New Member

Topic starter

Boa Tarde, galera!

Criei um botão Gravar, ele pega os dados inseridos na plan Compras e grava na plan ENTRADA. Ele funciona porém está
demorando muito para gravar, tem um delay (demora) em torno de 10 a 12 segundos para gravar com sucesso.

Tem alguma forma de arrumar o código para que o mesmo fique mais rápido?

Sub Gravar_Compras()

Application.ScreenUpdating = False
Dim Data As Date
Dim Codigo As Variant
Dim Descr As String
Dim Line As String
Dim Marca As String
Dim quant As Integer
Dim Preco As Double
Dim Total As Double
Dim UltimaCel As Integer

Dim QuantDados As Integer
Dim linha As Integer

QuantDados = Sheets("COMPRAS").Range("B17").End(xlUp).Row
linha = 7
While linha < QuantDados + 1

Sheets("COMPRAS").Select
 Data = Range("D2").Value
 Codigo = Range("B" & linha).Value
 Descr = Range("D" & linha).Value
 Line = Range("F" & linha).Value
 Marca = Range("H" & linha).Value
 quant = Range("J" & linha).Value
 Preco = Range("L" & linha).Value
 Total = Range("N" & linha).Value

Sheets("ENTRADA").Select

UltimaCel = Range("A50000").End(xlUp).Row + 1

 Range("A" & UltimaCel).Value = Codigo
 Range("B" & UltimaCel).Value = Data
 Range("C" & UltimaCel).Value = Descr
 Range("D" & UltimaCel).Value = Line
 Range("E" & UltimaCel).Value = Marca
 Range("F" & UltimaCel).Value = quant
 Range("G" & UltimaCel).Value = Preco
 Range("H" & UltimaCel).Value = Total
linha = linha + 1
Wend

Sheets("COMPRAS").Select
Range("D3").Value = Range("D3").Value + 1

On Error Resume Next
Range("B7:N27").Cells.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
 Range("J7").Value = ""
MsgBox "Gravado com sucesso"

Application.ScreenUpdating = True
End Sub

Postado : 28/10/2014 9:32 am

Fernando Fernandes

(@fernandofernandes)

Posts: 43750

Illustrious Member

Boa tarde!!

Eu não mudei nada na rotina principal, apenas em alguns métodos.

Sub Gravar_Compras()
Dim Data As Date
Dim Codigo As Variant
Dim Descr As String
Dim Line As String
Dim Marca As String
Dim quant As Integer
Dim Preco As Double
Dim Total As Double
Dim UltimaCel As Integer

Dim QuantDados As Integer
Dim linha As Integer
   With Application
       .ScreenUpdating = False
       .Calculation = xlCalculationManual
       .EnableEvents = False
       .DisplayAlerts = False
   End With
    QuantDados = Sheets("COMPRAS").Range("B17").End(xlUp).Row
linha = 7
While linha < QuantDados + 1

Sheets("COMPRAS").Select
Data = Range("D2").Value
Codigo = Range("B" & linha).Value
Descr = Range("D" & linha).Value
Line = Range("F" & linha).Value
Marca = Range("H" & linha).Value
quant = Range("J" & linha).Value
Preco = Range("L" & linha).Value
Total = Range("N" & linha).Value

Sheets("ENTRADA").Select

UltimaCel = Range("A50000").End(xlUp).Row + 1

Range("A" & UltimaCel).Value = Codigo
Range("B" & UltimaCel).Value = Data
Range("C" & UltimaCel).Value = Descr
Range("D" & UltimaCel).Value = Line
Range("E" & UltimaCel).Value = Marca
Range("F" & UltimaCel).Value = quant
Range("G" & UltimaCel).Value = Preco
Range("H" & UltimaCel).Value = Total
linha = linha + 1
Wend

Sheets("COMPRAS").Select
Range("D3").Value = Range("D3").Value + 1

On Error Resume Next
Range("B7:N27").Cells.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
Range("J7").Value = ""
MsgBox "Gravado com sucesso"

   With Application
       .ScreenUpdating = True
       .EnableEvents = True
       .DisplayAlerts = True
       .Calculation = xlCalculationAutomatic
   End With
End Sub

Se não resolver dê retorno.
O interessante seria postar seu arquivo modelo.
Att

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

Postado : 28/10/2014 1:10 pm