Boa Tarde pessoal, estou precisando de uma ajuda de VCs para decifrar esse enigma, pois o formulário de pesquisa não abre devido a um erro que não consigo localizar ...

Desde já agradeço !!!

End Sub

Private Sub txtCartaoSUS_Change()

End Sub

Private Sub UserForm_Initialize() <-- Esta linha aparece destacado em Amarelo
'lv.ListItems.Clear 'Clear ListView from previous filled data
lstLista.ColumnHeaders.Clear 'Clear the Column Headers <-- Nesta linha lstLista aparece destacado Azul
lstLista.ListItems.Clear
With lstLista
.Gridlines = True
.View = lvwReport
'.FullRowSelect
' .ColumnHeaders.Add Text:="ID", Width:=20
' .ColumnHeaders.Add Text:="NOME", Width:=60
' .ColumnHeaders.Add Text:="Endereço", Width:=120
' .ColumnHeaders.Add Text:="CartaoSUS", Width:=120
' .ColumnHeaders.Add Text:="Registro", Width:=7
' .ColumnHeaders.Add Text:="BAIRRO", Width:=50
End With

'preenche o cboDirecao e seleciona o primeiro item
cboDirecao.Clear
cboDirecao.AddItem "Ascendente"
cboDirecao.AddItem "Descendente"
cboDirecao.ListIndex = 0

Call DefinePlanilhaDados
Call PopulaCidades
Call PopulaListBox(vbNullString, vbNullString, vbNullString, vbNullString, vbNullString)
End Sub

Private Sub Exportar()
Dim i As Integer
Dim NewWorkBook As Workbook
Dim rst As ADODB.Recordset
' Preenche o RecordSet com os filtros atuais
Set rst = PreecheRecordSet(txtNomePaciente.Text, txtAdmissao.Text, txtEndereco.Text, txtRegistro.Text, txtCartaoSUS.Text)
'cria um novo Workbook
Set NewWorkBook = Application.Workbooks.Add
' Efetua loop em todos os campos, retornando os nomes de campos
' à planilha.
For i = 0 To rst.Fields.Count - 1
NewWorkBook.Sheets(1).Range("A1").Offset(0, i).Value = rst.Fields(i).Name
Next i

NewWorkBook.Sheets(1).Range("A2").CopyFromRecordset rst
NewWorkBook.Activate
End Sub

Private Sub PopulaCidades()
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sql As String

Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.JET.OLEDB.4.0"
.ConnectionString = "Data Source=" & caminhoArquivoDados & ";Extended Properties=Excel 8.0;"
.Open
End With

sql = "SELECT DISTINCT Bairro FROM [Fornecedores$]"

Set rst = New ADODB.Recordset
With rst
.ActiveConnection = conn
.Open sql, conn, adOpenDynamic, _
adLockBatchOptimistic
End With

Do While Not rst.EOF
If Not IsNull(rst(0).Value) Then
lstCidades.AddItem rst(0).Value
End If
rst.MoveNext
Loop

' Fecha o conjunto de registros.
Set rst = Nothing
' Fecha a conexão.
conn.Close

End Sub

Private Sub PopulaListBox(ByVal NomePaciente As String, _
ByVal Admissao As String, _
ByVal Endereco As String, _
ByVal Registro As String, _
ByVal CartaoSUS As String)

On Error GoTo TrataErro

Dim rst As ADODB.Recordset
Dim campo As Field
Dim myArray() As Variant
Dim i As Integer
Dim li As ListItem, fld As Field, ch As ColumnHeader

Dim Column As Long
Dim Counter As Long
Counter = 0

Set rst = PreecheRecordSet(txtNomePaciente.Text, txtAdmissao.Text, txtEndereco.Text, txtRegistro.Text, txtCartaoSUS.Text)

'preenche o combobox com os nomes dos campos
'persiste o índice
Dim indiceTemp As Long
indiceTemp = cboOrdenarPor.ListIndex
cboOrdenarPor.Clear
For Each campo In rst.Fields
cboOrdenarPor.AddItem campo.Name
Next
'recupera o índice selecionado
cboOrdenarPor.ListIndex = indiceTemp

'Colunas a Preencher Inicia na Primeira
For i = 0 To rst.Fields.Count - 1 'For i = 1 : a partir da 2ª coluna
Set ch = lstLista.ColumnHeaders.Add(, , rst.Fields(i).Name)
'ch.Width = 48 'Define o Tamanho de Todas as COLUNAS
'MsgBox rst.Fields(i).Name
Next

'Clear the Column Headers
lstLista.ListItems.Clear

'coloca as linhas do RecordSet num Array, se houver linhas neste
If Not rst.BOF Then
Do While Not rst.EOF

'Preenche o LISTVIEW a partir da 2ª Coluna
'Set li = lstLista.ListItems.Add(, "k" & rst.Fields(0), CheckNull(rst.Fields(1)))
'Fill in the rest of the columns
'For i = 2 To rst.Fields.Count - 1
'li.SubItems(i - 1) = CheckNull(rst.Fields(i))

'Preenche o LISTVIEW a partir da 1ª Coluna
Set li = lstLista.ListItems.Add(, "k" & rst.Fields(0), CheckNull(rst.Fields(0)))
'Fill in the rest of the columns
For i = 1 To rst.Fields.Count - 1
li.SubItems(i) = CheckNull(rst.Fields(i))
Next

rst.MoveNext 'Move to next record
Loop

'Define os Tamanhos das colunas automaticamente
Call TamanhoColAutomatico

End If
'atualiza o label de mensagens
If rst.RecordCount <= 0 Then
lblMensagens.Caption = rst.RecordCount & " registros encontrados"
Else
lblMensagens.Caption = rst.RecordCount & " registros encontrados"
End If

Exit Sub

' Fecha o conjunto de registros.
Set rst = Nothing
' Fecha a conexão.
'conn.Close

TrataSaida:
Exit Sub
TrataErro:
Debug.Print Err.Description & vbNewLine & Err.Number & vbNewLine & Err.Source
MsgBox Err.Description & vbNewLine & Err.Number & vbNewLine & Err.Source
Resume TrataSaida
End Sub

Private Sub TamanhoColAutomatico()
Dim Column As Long
Dim Counter As Long
Counter = 0
For Column = Counter To lstLista.ColumnHeaders.Count - 2
SendMessage lstLista.hWnd, LVM_SETCOLUMNWIDTH, Column, LVSCW_AUTOSIZE_USEHEADER
Next
End Sub

Public Function CheckNull(FieldValue As Variant)
On Error GoTo Error

If IsNull(FieldValue) Then
CheckNull = ""
Else
CheckNull = FieldValue
End If
' Exit Sub
Error:
'GeneralErrors "CheckNull", Err.Number, Err.Description
Resume Next
End Function

Private Function PreecheRecordSet(ByVal NomePaciente As String, _
ByVal Admissao As String, _
ByVal Endereco As String, _
ByVal Registro As String, _
ByVal CartaoSUS As String) As Recordset
On Error GoTo TrataErro

Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sql As String
Dim sqlWhere As String
Dim sqlOrderBy As String
Dim i As Integer
Dim campo As Field
Dim myArray() As Variant

Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.JET.OLEDB.4.0"
.ConnectionString = "Data Source=" & caminhoArquivoDados & ";Extended Properties=Excel 8.0;"
.Open
End With

sql = "SELECT * FROM [Fornecedores$]"

'monta a cláusula WHERE
'NomeDoPaciente
Call MontaClausulaWhere(txtNomePaciente.Name, "NomeDoPaciente", sqlWhere)

'Admissão
Call MontaClausulaWhere(txtAdmissao.Name, "Admissão", sqlWhere)

'Endereço
Call MontaClausulaWhere(txtEndereco.Name, "Endereço", sqlWhere)

'Bairro
For i = 1 To lstCidades.ListCount
'verifica se o item está selecionado
If lstCidades.Selected(i - 1) Then
'Monta a cláusula WHERE com OR
Debug.Print lstCidades.List(i - 1) & " selecionado"
If sqlWhere <> vbNullString Then
sqlWhere = sqlWhere & " OR"
End If
sqlWhere = sqlWhere & " UCASE(Bairro) LIKE UCASE('%" & Trim(lstCidades.List(i - 1)) & "%')"
End If
Next

'Registro
Call MontaClausulaWhere(txtRegistro.Name, "Registro", sqlWhere)

'CartaoSUS
Call MontaClausulaWhere(txtCartaoSUS.Name, "CartaoSUS", sqlWhere)

'faz a união da string SQL com a cláusula WHERE
If sqlWhere <> vbNullString Then
sql = sql & " WHERE " & sqlWhere
End If

'faz a união da string SQL com a cláusula ORDER BY
If cboOrdenarPor.ListIndex <> -1 Then
sqlOrderBy = " ORDER BY " & cboOrdenarPor.List(cboOrdenarPor.ListIndex, 0)
'define a direção
Select Case cboDirecao.ListIndex
Case Ascendente
sqlOrderBy = sqlOrderBy & " ASC"
Case Descendente
sqlOrderBy = sqlOrderBy & " DESC"
End Select
'une a query order ao sql
sql = sql & sqlOrderBy
End If

Set rst = New ADODB.Recordset
rst.CursorLocation = adUseClient
With rst
.ActiveConnection = conn
.Open sql, conn, adOpenForwardOnly, _
adLockBatchOptimistic
End With

Set rst.ActiveConnection = Nothing

' Fecha a conexão.
conn.Close

Set PreecheRecordSet = rst
Exit Function
TrataErro:
Set rst = Nothing
End Function

Private Sub MontaClausulaWhere(ByVal NomeControle As String, ByVal NomeCampo As String, ByRef sqlWhere As String)
'Admissao
If Trim(Me.Controls(NomeControle).Text) <> vbNullString Then
If sqlWhere <> vbNullString Then
sqlWhere = sqlWhere & " AND"
End If
sqlWhere = sqlWhere & " UCASE(" & NomeCampo & ") LIKE UCASE('%" & Trim(Me.Controls(NomeControle).Text) & "%')"
End If
End Sub

'Faz a transpasição de um array, transformando linhas em colunas
Private Function Array2DTranspose(avValues As Variant) As Variant
Dim lThisCol As Long, lThisRow As Long
Dim lUb2 As Long, lLb2 As Long
Dim lUb1 As Long, lLb1 As Long
Dim avTransposed As Variant

If IsArray(avValues) Then
On Error GoTo ErrFailed
lUb2 = UBound(avValues, 2)
lLb2 = LBound(avValues, 2)
lUb1 = UBound(avValues, 1)
lLb1 = LBound(avValues, 1)

ReDim avTransposed(lLb2 To lUb2, lLb1 To lUb1)
For lThisCol = lLb1 To lUb1
For lThisRow = lLb2 To lUb2
avTransposed(lThisRow, lThisCol) = avValues(lThisCol, lThisRow)
Next
Next
End If

Array2DTranspose = avTransposed
Exit Function

ErrFailed:
Debug.Print Err.Description
Debug.Assert False
Array2DTranspose = Empty
Exit Function
Resume
End Function