Notifications
Clear all

codigo muito lento

17 Posts
4 Usuários
0 Reactions
3,711 Visualizações
(@fagneribas)
Posts: 67
Trusted Member
Topic starter
 

Private Sub CommandButton5_Click()
' CARREGA DADOS DO LISTVIEW E FILTRA NA PLANILHA E ALTERA
On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

Planilha1.Activate
Planilha1.Select

Dim resultado As VbMsgBoxResult
resultado = MsgBox("TEM CERTEZA QUE DESEJA REALIZAR ESSA VENDA?", vbYesNo, "F R CONTROLES")
If resultado = vbYes Then

Dim i As Integer, j As Integer
'conta qunatas linhas tem na minha listview
For i = 1 To ListView1.ListItems.Count
'valor procurado no listview

Dim codigo As Double
codigo = CDbl(ListView1.ListItems.ITEM(i))

ListView1.ListItems(i).Text = Empty
'fecha a busca no listview e limpa as linhas
'busca os dados na planilha e altera

Dim novalinha As Long
For novalinha = 2 To Worksheets("ESTOQUE").UsedRange.Rows.Count

'while Worksheets("ESTOQUE").Range("A" & novalinha).value <> ""

'With Worksheets("ESTOQUE").Range("A:A")
'Set c = .Find(codigo, LookIn:=xlValues, LookAt:=xlWhole)

'If Not c Is Nothing Then
If CDbl(Worksheets("ESTOQUE").Range("A" & novalinha).Value) = codigo Then
''c.Activate
'c.Select
Worksheets("ESTOQUE").Range("A" & novalinha).Select
Rows(Selection.Row).Interior.ColorIndex = 8
Selection.Columns(9) = ComboBox1.Value 'CLIENTE
Selection.Columns(11) = Format(TextBox3.Value, "mm/dd/yyyy") ' DATA
Selection.Columns(13) = ComboBox2.Value
'End If
'End With
End If
'novalinha = novalinha+1
'wend
Next novalinha

'fecha a busca na planilha e altera

For j = 1 To ListView1.ColumnHeaders.Count - 1

ListView1.ListItems(i).ListSubItems(j).Text = Empty

Next j

Next i

ListView1.ListItems.Clear
TextBox3 = ""
ComboBox1 = ""
ComboBox2 = ""
Label9 = ""
Label7 = ""

MsgBox "VENDA REALIZADA COM SUCESSO", vbInformation, "F R CONTROLES"

Else

MsgBox "CANCELADO COM SUCESSO", vbInformation, "F R CONTROLES"
Exit Sub
End If
' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic

Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM AO REALIZAR A VENDA", vbInformation, "F R CONTROLES"

End Sub

tenho esse codigo ele funciona corretamente, porem demora muito para terminar o seu objetivo, alguem pode me ajudar a deixar ele mais rapido, ele serve para alterar toras as linhas q forem iguais a da minha pesquisa, porem ele demora muito quando for grande a quantidade de numeros iguais, alguem pode me ajudar?

 
Postado : 20/08/2018 7:49 am
xlarruda
(@xlarruda)
Posts: 732
Honorable Member
 

Não sei se está usando essa linha, mas caso esteja tente trocar:

'With Worksheets("ESTOQUE").Range("A:A")

por

'With Worksheets("ESTOQUE").Range("A1:A" & Sheets("ESTOQUE").UsedRange.Rows.Count)

___________________________________________________________________________________________
Se a resposta atendeu sua dúvida, por favor, clique no Gostei e marque o Tópico como [Resolvido].

Att.

André Arruda

 
Postado : 20/08/2018 8:30 am
(@fagneribas)
Posts: 67
Trusted Member
Topic starter
 

amigo nao deu certo, continua lento, se eu mandar o projeto vc n consegue me dar essa força?

 
Postado : 20/08/2018 11:18 am
xlarruda
(@xlarruda)
Posts: 732
Honorable Member
 

manda ai, podemos tentar...

___________________________________________________________________________________________
Se a resposta atendeu sua dúvida, por favor, clique no Gostei e marque o Tópico como [Resolvido].

Att.

André Arruda

 
Postado : 20/08/2018 12:26 pm
(@fagneribas)
Posts: 67
Trusted Member
Topic starter
 

meu problema e no formulario de vendas, na hora q eu clico em vender ele demora de mais para realizar a venda. principalemente quando existe varios linhas com o mesmo codigo na colula "A", consegue me ajudar?

 
Postado : 20/08/2018 12:48 pm
xlarruda
(@xlarruda)
Posts: 732
Honorable Member
 

Nao veio o arquivo. Veio apenas um link

___________________________________________________________________________________________
Se a resposta atendeu sua dúvida, por favor, clique no Gostei e marque o Tópico como [Resolvido].

Att.

André Arruda

 
Postado : 20/08/2018 12:55 pm
(@fagneribas)
Posts: 67
Trusted Member
Topic starter
 

https://www.dropbox.com/s/vtruv9u99n3n4 ... O.rar?dl=0
link do aquivo

 
Postado : 20/08/2018 1:48 pm
xlarruda
(@xlarruda)
Posts: 732
Honorable Member
 

Abri aqui seu arquivo e não vi nada demais.
Quando clico em realizar a venda, o procedimento é feito de forma rápida.

Talvez algum colega aqui do fórum com mais conhecimento possa te ajudar melhor. Abrç!

___________________________________________________________________________________________
Se a resposta atendeu sua dúvida, por favor, clique no Gostei e marque o Tópico como [Resolvido].

Att.

André Arruda

 
Postado : 20/08/2018 3:23 pm
(@fagneribas)
Posts: 67
Trusted Member
Topic starter
 

Coloque pra baixar umas 15 milhas mais ou menos pra vc ver q ele fica bem lerdo chega travar o Excel, só faça o teste para vc visualizar

 
Postado : 20/08/2018 3:41 pm
(@teleguiado)
Posts: 142
Estimable Member
 

Até o filtro estava lento.
Uma coisa que percebi é que os nomes criados estão selecionando um range muito grande.

Para o Nome "Items"

=IMPRESSÃO!$K:$M

Para o Nome "ESPÉCIE"

=IMPRESSÃO!$E$9:$E$1048576

Seria melhor definir um range menor.
Para o Nome "Items"

=IMPRESSÃO!$K1:$M16

Para o Nome "ESPÉCIE"

=IMPRESSÃO!$E$9:$E$448

Quando alterei isso ate o filtro da planilha ficou mais rápido.

Obrigado.

Teleguiado.
E-mail: [email protected]

 
Postado : 20/08/2018 4:09 pm
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Alem do ja informado/sugerido, em seu formulário--> "Relatorio de Entrada" <-- (não olhei os demais), a rotina de preenchimento do listview deve ser alterada conforme abaixo.
Alteração Principal: Retirada do trecho que formata o campo como vermelho do corpo de preenchimento/povoamento da listview.
Motivo: A cada item acrescido essa rotina "repassa" todos os demais "para colorir", ou seja se houver 4000 itens na listview vai "repassar" de forma exponencial gerando um grande delay

Experimente:

Private Sub CommandButton6_Click()
'Dim linhalist As Integer
Dim LINHA As Integer
Dim valor_celula As String
Dim DATA As Date, Data1 As Date, Fim As Date

On Error GoTo ERRO

' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
 Application.DisplayAlerts = False
Application.EnableEvents = False

'Call TIRAR_FORMATAÇAO

' FILTRA E ENVIA PRA LISTVIEW1 NUNCA MEXER OU APAGAR
If TextBox4 = "" Or TextBox7 = "" Then
    MsgBox "Escolher data de Inicio e Fim!", vbCritical, "F R CONTROLES"
    Exit Sub
End If

Data1 = TextBox4
Fim = TextBox7

'linhalist = 0
LINHA = 2

ListView1.ListItems.Clear

Planilha1.Select

With Planilha1
    While .Cells(LINHA, 1).Value <> ""
        valor_celula = .Cells(LINHA, 1).Value
        If UCase(Left(valor_celula, Len(TextBox5))) = UCase(TextBox5) Then ' PACOTE
            valor_celula = .Cells(LINHA, 3).Value
            If UCase(Left(valor_celula, Len(ComboBox2.Text))) = UCase(ComboBox2.Text) Then 'ESPECIE
                valor_celula = .Cells(LINHA, 4).Value
                If UCase(Left(valor_celula, Len(TextBox1.Text))) = UCase(TextBox1.Text) Then 'COMPRIMENTO
                    valor_celula = .Cells(LINHA, 5).Value
                    If UCase(Left(valor_celula, Len(TextBox2.Text))) = UCase(TextBox2.Text) Then ' LARGURA
                        valor_celula = .Cells(LINHA, 6).Value
                        If UCase(Left(valor_celula, Len(TextBox3.Text))) = UCase(TextBox3.Text) Then 'ESPESSURA
                            valor_celula = .Cells(LINHA, 12).Value
                            If UCase(Left(valor_celula, Len(ComboBox3.Text))) = UCase(ComboBox3.Text) Then 'CLIENTE
                                DATA = .Cells(LINHA, 2).Value
                                If DATA >= Data1 And DATA <= Fim Then
                                    With ListView1
                                        Set LISTA = ListView1.ListItems.Add(Text:=Cells(LINHA, "a").Value) ' PACOTE
                                        LISTA.ListSubItems.Add Text:=Cells(LINHA, "B").Value 'DATA
                                        LISTA.ListSubItems.Add Text:=Cells(LINHA, "C").Value 'ESPECIE
                                        LISTA.ListSubItems.Add Text:=Format(Cells(LINHA, "D").Value, "0.00") 'COMPRIMENTO
                                        LISTA.ListSubItems.Add Text:=Format(Cells(LINHA, "E").Value, "0.0") 'LARGURA
                                        LISTA.ListSubItems.Add Text:=Format(Cells(LINHA, "F").Value, "0.0") 'ESPESSURA
                                        LISTA.ListSubItems.Add Text:=Cells(LINHA, "G").Value 'PEÇAS
                                        LISTA.ListSubItems.Add Text:=Format(Cells(LINHA, "H").Value, "0.000") 'QTD M ³
                                        LISTA.ListSubItems.Add Text:=Cells(LINHA, "I").Value 'SITUAÇÃO
                                        LISTA.ListSubItems.Add Text:=Cells(LINHA, "J").Value 'CLASSIFICAÇÃO
                                        'LISTA.ListSubItems.Add Text:=Cells(Linha, "L").Value 'CLASSIFICAÇÃO
                                    End With
                                    
                                'linhalist = linhalist + 1
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        End If
        LINHA = LINHA + 1
    Wend
End With
'Formata se o valor do campo for zero
For i = 1 To ListView1.ListItems.Count
    If ListView1.ListItems.ITEM(i).ListSubItems(7).Text >= 0 Then
        ListView1.ListItems.ITEM(i).ListSubItems(7).ForeColor = RGB(255, 102, 51)
    End If
Next i

'Call PREPARA_IMPRESSAO

CommandButton4.Visible = True
CommandButton5.Visible = True
Call contar
Call SOMAR
Call descer
'Call PREPARA_IMPRESSAO
MsgBox "BUSCA REALIZADA COM SUCESSO ", vbInformation, "F R CONTROLES"
CommandButton4.Visible = True
CommandButton5.Visible = True

Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM ERRO AO FAZER A BUSCA ", vbInformation, "F R CONTROLES"
End Sub

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

 
Postado : 20/08/2018 5:59 pm
(@fagneribas)
Posts: 67
Trusted Member
Topic starter
 

boa dica obg, amigo ireia fazer os ajustes, consegue me dar uma força no formulario vendas? pq quando a quantidade de e grandes de linhas o programa chega ate a travar quando clico em vender, ele fica muito lento tipo dando um loop sem final. sera q vc n consegue me ajudar?

 
Postado : 21/08/2018 5:16 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Apesar de não conseguir entender coerentemente a mecânica de seu projeto; fiz algumas alterações, experimente

Botão adiciona

Private Sub CommandButton1_CLICK()
On Error GoTo ERRO
Dim vcodigo As String
Dim i As Long, UltimaLinha As Long
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

'NAO DEIXA CAMPOS VAZIOS
If TextBox1.Value = "" Or ComboBox1.Value = "" Or TextBox3.Value = "" Or ComboBox2.Value = "" Then
    MsgBox "TODOS OS CAMPOS DEVEM SER PREENCHIDOS", vbInformation, "F R CONTROLES"
    Exit Sub
End If
    
UltimaLinha = Sheets("ESTOQUE").Cells(Cells.Rows.Count, 1).End(xlUp).Row
If UltimaLinha < 2 Then UltimaLinha = 2

ListView1.ListItems.Clear
vcodigo = TextBox1
With Sheets("ESTOQUE")
    For i = 1 To UltimaLinha
        If Range("A" & i).Value = vcodigo Then
            Set LINHA = ListView1.ListItems.Add(Text:=.Range("A" & i).Value) ' PLAQUETA
                LINHA.ListSubItems.Add Text:=TextBox3.Value ' DATA
                LINHA.ListSubItems.Add Text:=.Range("C" & i).Value ' ESPECIE
                LINHA.ListSubItems.Add Text:=Format(.Range("D" & i).Value, "0.00") ' COMPRIMENTO
                LINHA.ListSubItems.Add Text:=Format(.Range("E" & i).Value, "0.0") ' LARGURA
                LINHA.ListSubItems.Add Text:=Format(.Range("F" & i).Value, "0.0") ' ESPESSURA
                LINHA.ListSubItems.Add Text:=Format(.Range("G" & i).Value, "0") ' PEÇAS
                LINHA.ListSubItems.Add Text:=Format(.Range("H" & i).Value, "0.000") ' TOTAL PEÇAS
                LINHA.ListSubItems.Add Text:=ComboBox1.Value ' CLIENTE
                LINHA.ListSubItems.Add Text:=Format(.Range("J" & i).Value, "0,000") ' CLASSIFICAÇÃO
        End If
    Next
End With
For i = 1 To ListView1.ListItems.Count
    If ListView1.ListItems.ITEM(i).ListSubItems(6).Text >= 0 Then ListView1.ListItems.ITEM(i).ListSubItems(6).ForeColor = RGB(0, 255, 255)
    If ListView1.ListItems.ITEM(i).ListSubItems(8).Text > "0" Then ListView1.ListItems.ITEM(i).ListSubItems(8).ForeColor = RGB(0, 0, 255)
    If ListView1.ListItems.ITEM(i).ListSubItems(7).Text >= 0 Then ListView1.ListItems.ITEM(i).ListSubItems(7).ForeColor = RGB(255, 102, 51)
Next

Call contar
Call SOMAR

CommandButton3.Visible = True
CommandButton4.Visible = True
CommandButton5.Visible = True
TextBox1 = ""
TextBox1.SetFocus

' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic

Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM ERRO", vbInformation, "F R CONTROLES"
End Sub

Botão Venda

Private Sub CommandButton5_Click()
Dim i As Integer, j As Integer
Dim resultado As VbMsgBoxResult
Dim NovaLinha As Long
Dim codigo As Double

' CARREGA DADOS DO LISTVIEW E FILTRA NA PLANILHA E ALTERA
On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

resultado = MsgBox("TEM CERTEZA QUE DESEJA REALIZAR ESSA VENDA?", vbYesNo, "F R CONTROLES")
If resultado = vbYes Then
    'conta qunatas linhas tem na minha listview
    For i = 1 To ListView1.ListItems.Count
        'valor procurado no listview
        codigo = CDbl(ListView1.ListItems.ITEM(i))
        'busca os dados na planilha e altera
        For NovaLinha = 2 To Sheets("ESTOQUE").Cells(Cells.Rows.Count, 1).End(xlUp).Row
            With Worksheets("ESTOQUE")
                If CDbl(Worksheets("ESTOQUE").Range("A" & NovaLinha).Value) = codigo Then
                    Worksheets("ESTOQUE").Range("A" & NovaLinha).Select
                    Rows(Selection.Row).Interior.ColorIndex = 8
                    Selection.Columns(9) = ComboBox1.Value 'CLIENTE
                    Selection.Columns(11) = Format(TextBox3.Value, "mm/dd/yyyy") ' DATA
                    Selection.Columns(13) = ComboBox2.Value
                End If
            End With
        Next NovaLinha
    
    ListView1.ListItems.Clear
    TextBox3 = ""
    ComboBox1 = ""
    ComboBox2 = ""
    Label9 = ""
    Label7 = ""
    MsgBox "VENDA REALIZADA COM SUCESSO", vbInformation, "F R CONTROLES"
    Next
Else
    MsgBox "CANCELADO COM SUCESSO", vbInformation, "F R CONTROLES"
Exit Sub
End If
' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic

Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM AO REALIZAR A VENDA", vbInformation, "F R CONTROLES"

End Sub

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

 
Postado : 21/08/2018 7:23 am
(@fagneribas)
Posts: 67
Trusted Member
Topic starter
 

codigo ficou otimo amigo, ele so esta dando um erro quando acaba os intens da listview, e possivel corrigir?

 
Postado : 21/08/2018 7:52 am
(@fagneribas)
Posts: 67
Trusted Member
Topic starter
 

resolvi o problema, porem estou com um outro problema, por exemplo quero baixar 3 pacotes ao mesmo tempo, e nao consigo o codigo so baixa 1, nao baixa todos de uma so vez, e possive corrigir esse erro?

 
Postado : 21/08/2018 8:46 am
Página 1 / 2