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