Este fórum está sendo desativado

[jmarcelosp]

Olá


Estou criando um filtro, e não está funcioando como esperado, não está aparecendo nada praticamente. E Outra dúvida, como faço para vincular ou disponibilizar a consulta em outra plainha ?

Filtragem errrada



Como deveria sair



Sub Importar_Dados()

On Error GoTo Erro

Application.ScreenUpdating = False


Dim Guia As Object
Dim Planilha As Workbook
Dim EnderecoPlan As String
Dim Coluna As Double, Linha As Double, ColDestino As Double
Dim ColInicial As Double, ColFinal As Double, LinOrigem As Double


EnderecoPlan = Application.GetOpenFilename(FileFilter:="file, *.xls*")


If EnderecoPlan <> Empty And EnderecoPlan <> "Falso" Then
Set Planilha = Application.Workbooks.Open(EnderecoPlan)
Else
Application.ScreenUpdating = True
Exit Sub
End If

Set Guia = Planilha.Worksheets(1)

Windows(Planilha.Name).Visible = False

Coluna = 1
Lin = 1


Inicio:

Do

Linha = Linha + 1

If Guia.Cells(Linha, Coluna).Value <> Empty Then
LinOrigem = Linha
ColInicial = Coluna


Do
Coluna = Coluna + 1
Loop Until Guia.Cells(Linha, Coluna).Value = Empty

ColFinal = Coluna - 1
Exit Do
End If

If Coluna = 100 Then
MsgBox "Não encontrado cabeçalho!", vbExclamation, "IMPORTAR"
Exit Sub
End If




Loop Until Linha = 10

If LinOrigem = Empty Then
Coluna = Coluna + 1
Linha = 1
GoTo Inicio:

End If

Coluna = ColIncial
ColDestino = 2
Linha = WorksheetFunction.CountA(Planilha1.Range("B:B")) + 3

With Planilha1

Do
LinOrigem = LinOrigem + 1

For Coluna = ColInicial To ColFinal
.Cells(Linha, ColDestino).Value = Guia.Cells(LinOrigem, Coluna).Value
ColDestino = ColDestino + 1
Next Coluna

ColDestino = 2
Linha = Linha + 1


Loop Until Guia.Cells(LinOrigem, ColInicial).Value = Empty

End With

Windows(Planilha.Name).Visible = True

Application.DisplayAlerts = False
Windows(Planilha.Name).Close
Application.DisplayAlerts = True


Set Planiha = Nothing
Set Guia = Nothing

Application.ScreenUpdating = True


Exit Sub
Erro:
MsgBox "Erro!", vbCritical, "IMPORTAR"

End Sub


Grato

[JCabral]

Veja se esse exemplo ajuda

https://excelsignum.com/2017/12/10/real ... n-listbox/

[jmarcelosp]

Galera, me desculpa coloquei os códigos errados , correto abaixo

Sub Filtro()
'On Error GoTo Erro

Dim TL As Double, Linha As Double, Coluna As Double, i As Double
Dim Criterio1 As String, Criterio2 As String, Criterio3 As String
Dim Arr As Variant
Dim arrayFiltro()

Criterio1 = TProduto.Text
Criterio2 = TCodigo.Text
Criterio3 = TNcm.Text


ListBox1.Clear
ListBox1.ColumnCount = 3
ListBox1.ColumnWidths = "60;120;120"

TL = WorksheetFunction.CountA(Planilha1.Range("A:A")) + 2

Arr = Planilha1.Range("A4:D" & TL).Value

TL = 1

For i = LBound(Arr, 1) To UBound(Arr, 1)

If VBA.UCase(Arr(i, 1)) Like VBA.UCase("*" & (Criterio1) & "*") And _
VBA.UCase(Arr(i, 2)) Like VBA.UCase("*" & (Criterio2) & "*") And _
VBA.UCase(Arr(i, 3)) Like VBA.UCase("*" & (Criterio3) & "*") Then
TL = TL + 1

End If


Next i

ReDim arrayFiltro(1 To TL, 1 To 3)

Linha = 2
For i = LBound(Arr, 1) To UBound(Arr, 1)

If VBA.UCase(Arr(i, 1)) Like VBA.UCase("*" & (Criterio1) & "*") And _
VBA.UCase(Arr(i, 2)) Like VBA.UCase("*" & (Criterio2) & "*") And _
VBA.UCase(Arr(i, 3)) Like VBA.UCase("*" & (Criterio3) & "*") Then
For Coluna = 1 To 7


arrayFiltro(Linha, Coluna) = Arr(i, Coluna)
Next Coluna

Linha = Linha + 1

End If

Next i

ListBox1.List = arrayFiltro()
Call Cabeçalho

Erase arrayFiltro()
Arr = Empty


Exit Sub

Erro:
MsgBox "Erro!", vbCritical, "FILTRO"

End Sub

Sub Cabeçalho()

With ListBox1
.AddItem
.List(0, 0) = "CODIGO"
.List(0, 1) = "PRODUTO"
.List(0, 2) = "NCM"


End With


End Sub

Private Sub TCodigo_Change()
Call Filtro
End Sub

Private Sub TNcm_Change()
Call Filtro
End Sub

Private Sub TProduto_Change()
Call Filtro


End Sub



Private Sub UserForm_Initialize()
Call Filtro
End Sub


Tive de reescrever e agora também está dando este erro "Subscrito fora do intervalo (Erro 9)"

Grato