Este vídeo explica:
https://youtu.be/3Inc1pblyXU
Private Sub CommandButton1_Click()
Dim linhalistbox As Long, rng As Range
Dim LR As Long, r As Range, LRf As Long, cod As Long
Dim datainicial As Date, datafinal As Date
Dim codprod As String, cx As Long, descr As Range
datainicial = CDate(Me.TextBox_datainicial.Value)
datafinal = CDate(Me.TextBox_datafinal.Value)
If datainicial = Empty Then
MsgBox ("Informe data inicial para pesquisa.")
Me.TextBox_datainicial.SetFocus
Exit Sub
End If
If datafinal = Empty Then
MsgBox ("Informe a data final para pesquisa.")
Me.TextBox_datafinal.SetFocus
Exit Sub
End If
ListBox1.Clear
With Sheets("Plan3")
.AutoFilterMode = False
LR = .Cells(Rows.Count, 1).End(3).Row
.Range("A1:E" & LR).AutoFilter Field:=1, Criteria1:=">=" & CDbl(datainicial), Operator:=xlAnd, Criteria2:="<=" & CDbl(datafinal)
If .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count = 1 Then .AutoFilterMode = False: Exit Sub
LRf = .Cells(Rows.Count, 1).End(3).Row
Set rng = .Range("D2:D" & LRf).Cells.SpecialCells(xlCellTypeVisible)
For Each r In rng
cod = Evaluate("SUMPRODUCT(SUBTOTAL(3,OFFSET(Plan3!D" & r.Row & ":D" & LRf & ",ROW(Plan3!D" & r.Row & ":D" & LRf & ")-MIN(ROW(D" & r.Row & ":D" & LRf & ")),,1))*(Plan3!D" & r.Row & ":D" & LRf & "=Plan3!" & r.Address & "))")
If cod = 1 Then
codprod = r.Value
cx = Evaluate("=SUMPRODUCT(SUBTOTAL(9,OFFSET(Plan3!E2:E" & LRf & ",ROW(C2:C" & LRf & ")-ROW(C2),,1)),--(Plan3!D2:D" & LRf & "=Plan3!" & r.Address & "))")
Set descr = Sheets("Plan2").[A:A].Find(codprod, lookat:=xlWhole)
ListBox1.AddItem
ListBox1.List(linhalistbox, 0) = codprod 'codigo produto
ListBox1.List(linhalistbox, 1) = descr.Offset(, 1).Value 'descrição do produto
ListBox1.List(linhalistbox, 2) = cx 'quantidade de caixas
linhalistbox = linhalistbox + 1
End If
Next r
.AutoFilterMode = False
End With
If ListBox1.ListCount > 0 Then
Btn_imprimir.Enabled = True
Btn_limpar.Enabled = True
End If
End Sub
Private Sub TextBox1_Change()
Dim x As Long
Dim y As Long
Dim somavalor As Double
Dim somaqtd As Double
Dim achou As Boolean
Me.ListView2.ListItems.Clear
Sheets("Plan1").Activate
'Adiciona itens na List_Produtos
UltimaLinha = Plan1.Cells(Rows.Count, "a").End(xlUp).Row
For x = 2 To UltimaLinha - 1
achou = False
For y = x + 1 To UltimaLinha
If Plan1.Range("B" & x).Value = Me.TextBox1.Text Then
If Plan1.Range("B" & x).Value = Plan1.Range("B" & y).Value Then
If Plan1.Range("C" & x).Value = Plan1.Range("C" & y).Value Then
achou = True
somaqtd = WorksheetFunction.SumIfs(Plan1.Range("E:E"), Plan1.Range("B:B"), Plan1.Range("B" & x).Value, Plan1.Range("C:C"), Plan1.Range("C" & x).Value)
somavalor = WorksheetFunction.SumIfs(Plan1.[F:F], Plan1.Range("B:B"), Plan1.Range("B" & x).Value, Plan1.Range("C:C"), Plan1.Range("C" & x).Value)
Set li = ListView2.ListItems.Add(Text:=Plan1.Cells(x, "a").Value)
li.ListSubItems.Add Text:=Plan1.Cells(x, "b").Value
li.ListSubItems.Add Text:=Plan1.Cells(x, "c").Value
li.ListSubItems.Add Text:=Plan1.Cells(x, "d").Value
li.ListSubItems.Add Text:=somaqtd
li.ListSubItems.Add Text:=Format(somavalor, "R$ #,##0.00;(#,##0.00)")
End If
End If
End If
'Txt_QtdEmba
Next
If achou = False Then
If Plan1.Range("B" & x).Value = Me.TextBox1.Text Then
Set li = ListView2.ListItems.Add(Text:=Plan1.Cells(x, "a").Value)
li.ListSubItems.Add Text:=Plan1.Cells(x, "b").Value
li.ListSubItems.Add Text:=Plan1.Cells(x, "c").Value
li.ListSubItems.Add Text:=Plan1.Cells(x, "d").Value
li.ListSubItems.Add Text:=Plan1.Cells(x, "e").Value
li.ListSubItems.Add Text:=Format(Plan1.Cells(x, "f").Value, "R$ #,##0.00;(#,##0.00)")
End If
End If
Next
inicio:
For x = 1 To Me.ListView2.ListItems.Count - 1
For y = x + 1 To Me.ListView2.ListItems.Count
If Me.ListView2.ListItems.Item(x).SubItems(1) = Me.ListView2.ListItems.Item(y).SubItems(1) Then
If Me.ListView2.ListItems.Item(x).SubItems(2) = Me.ListView2.ListItems.Item(y).SubItems(2) Then
Me.ListView2.ListItems.Remove (y)
GoTo inicio
End If
End If
Next y
Next x
End Sub
Private Sub UserForm_Initialize()
Call Cabecalho
Call Atualisalistprodutos
End Sub
Sub Cabecalho()
'Preenche o cabeçalho do listview
With Me.ListView1
.CheckBoxes = False
.Gridlines = True
.View = lvwReport
.FullRowSelect = True
.ColumnHeaders.Add Text:="RG", Width:=15 '0
.ColumnHeaders.Add Text:="PEDIDO", Width:=60, Alignment:=2 '1
.ColumnHeaders.Add Text:="CODIGO", Width:=60, Alignment:=2 '1
.ColumnHeaders.Add Text:="PRODUTO", Width:=155, Alignment:=2 '2
.ColumnHeaders.Add Text:="QTD", Width:=60, Alignment:=2 '3
.ColumnHeaders.Add Text:="VALOR", Width:=60, Alignment:=2 '4
End With
With Me.ListView2
.CheckBoxes = False
.Gridlines = True
.View = lvwReport
.FullRowSelect = True
.ColumnHeaders.Add Text:="RG", Width:=15 '0
.ColumnHeaders.Add Text:="PEDIDO", Width:=60, Alignment:=2 '1
.ColumnHeaders.Add Text:="CODIGO", Width:=60, Alignment:=2 '1
.ColumnHeaders.Add Text:="PRODUTO", Width:=155, Alignment:=2 '2
.ColumnHeaders.Add Text:="QTD", Width:=60, Alignment:=2 '3
.ColumnHeaders.Add Text:="VALOR", Width:=60, Alignment:=2 '4
End With
End Sub
'
Sub Atualisalistprodutos()
Me.ListView1.ListItems.Clear
Sheets("Plan1").Activate
'Adiciona itens na List_Produtos
UltimaLinha = Plan1.Cells(Rows.Count, "a").End(xlUp).Row
For x = 2 To UltimaLinha
Set li = ListView1.ListItems.Add(Text:=Plan1.Cells(x, "a").Value)
li.ListSubItems.Add Text:=Plan1.Cells(x, "b").Value
li.ListSubItems.Add Text:=Plan1.Cells(x, "c").Value
li.ListSubItems.Add Text:=Plan1.Cells(x, "d").Value
li.ListSubItems.Add Text:=Plan1.Cells(x, "e").Value
li.ListSubItems.Add Text:=Format(Plan1.Cells(x, "f"), "R$ #,##0.00;(#,##0.00)")
'Txt_QtdEmba
Next
End Sub
Este post foi modificado 4 anos atrás 3 vezes por
AndersonEm 90% dos casos em que não se anexa o arquivo, ocorrem mal-entendidos, gerando perda de tempo de ambos os lados.
Postado : 07/09/2020 2:58 pm