Bom dia Alexandre,
Segue abaixo os códigos dos formulários para avaliação:
Código do Formulário de Pesquisa:
Private Const NomePlanSaida As String = "Dados"
Private Const LinhaCabecalho As Integer = 1
'INICIO EVENTOS FORMATAÇÃO DOS TEXTBOX DATAS
Private Sub dataf_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Limita a Qde de caracteres
dataf.MaxLength = 10
'para permitir que apenas números sejam digitados
If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then
KeyAscii = 0
End If
End Sub
Private Sub dataf_Change()
'Formata : dd/mm/aaaa
If Len(dataf) = 2 Or Len(dataf) = 5 Then
dataf.Text = dataf.Text & "/"
SendKeys "{End}", True
End If
End Sub
Private Sub datai_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Limita a Qde de caracteres
datai.MaxLength = 10
'para permitir que apenas números sejam digitados
If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then
KeyAscii = 0
End If
End Sub
Private Sub datai_Change()
'Formata : dd/mm/aaaa
If Len(datai) = 2 Or Len(datai) = 5 Then
datai.Text = datai.Text & "/"
SendKeys "{End}", True
End If
End Sub
'FIM EVENTOS FORMATAÇÃO DOS TEXTBOX DATAS
Private Sub UserForm_Activate()
'Set a reference to Microsoft Windows Common Controls by
'using Tools > References in the Visual Basic Editor (Alt+F11)
'Define algumas propriedades do ListView
With Me.lstLista
.Gridlines = True
.HideColumnHeaders = False
.View = lvwReport
End With
'Preenche Combo Box
setor.AddItem ""
setor.AddItem "Administração"
setor.AddItem "CD 2"
setor.AddItem "HPBE"
setor.AddItem "Logistica"
setor.AddItem "Manutenção"
setor.AddItem "Meio Ambiente"
setor.AddItem "PCP"
setor.AddItem "Qualidade"
setor.AddItem "Segurança"
setor.AddItem "SMBE"
setor.ListIndex = 0
'Chama a sub para preencher a ListView
Call LoadListView
End Sub
Sub RestauraControles()
datai.Value = ""
dataf.Value = ""
nome.Value = ""
Call LoadListView
nome.SetFocus
End Sub
Private Sub limpa_Click()
RestauraControles
End Sub
Private Sub fechar_Click()
Unload cmsPesquisa
End Sub
'Preenche a ListView
Private Sub LoadListView()
Dim ws As Worksheet
Dim coluna As Integer
Dim linha As Integer
Dim itm As ListItem, n As Long, lngCol As Long
Dim vardata As Variant
Set ws = ThisWorkbook.Worksheets(NomePlanSaida)
coluna = 1
linha = LinhaCabecalho
Me.lstLista.ListItems.Clear
Me.lstLista.ColumnHeaders.Clear
vardata = ws.Range("A1").CurrentRegion.Value
With ws
While .Cells(linha, coluna).Value <> Empty
With lstLista
.View = lvwReport
.Gridlines = True
.ColumnHeaders.Add Text:=ws.Cells(linha, coluna), Width:=ws.Cells(linha, coluna).Width
End With
coluna = coluna + 1
Wend
'Preenche as Linhas
With lstLista
For n = 2 To UBound(vardata)
Set itm = .ListItems.Add(n - 1, , vardata(n, 1))
For lngCol = 2 To UBound(vardata, 2)
'verifica se é Data e formata a Coluna
If IsDate(vardata(n, lngCol)) Then
itm.ListSubItems.Add , , Format(vardata(n, lngCol), "dd/mm/yyyy")
Else
itm.ListSubItems.Add , , vardata(n, lngCol)
End If
Next lngCol
Next n
End With
End With
End Sub
'Consulta Nome
Sub nome_Change()
lastRow = Plan2.Cells(Rows.Count, "a").End(xlUp).Row
lstLista.ListItems.Clear
'Adiciona itens
For x = 2 To lastRow
If UCase(Plan2.Cells(x, 2)) Like "*" & UCase(nome) & "*" Then
Set li = lstLista.ListItems.Add(Text:=Plan2.Cells(x, "a").Value)
li.ListSubItems.Add Text:=Plan2.Cells(x, "b").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "c").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "d").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "e").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "f").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "g").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "h").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "i").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "j").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "k").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "l").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "m").Value
End If
Next
End Sub
'Consulta Área de Impacto
Sub setor_Change()
lastRow = Plan2.Cells(Rows.Count, "a").End(xlUp).Row
lstLista.ListItems.Clear
'Adiciona itens
For x = 2 To lastRow
If UCase(Plan2.Cells(x, 4)) Like "*" & UCase(setor) & "*" Then
Set li = lstLista.ListItems.Add(Text:=Plan2.Cells(x, "a").Value)
li.ListSubItems.Add Text:=Plan2.Cells(x, "b").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "c").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "d").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "e").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "f").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "g").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "h").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "i").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "j").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "k").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "l").Value
li.ListSubItems.Add Text:=Plan2.Cells(x, "m").Value
End If
Next
End Sub
'Filtrar pelas Datas
Private Sub cbtSo2Dts_Click()
Dim i As Long
If datai = "" Then
MsgBox "Digite uma Data Valida", , "Data Inicial Obrigatória!!!"
datai.SetFocus
Exit Sub
End If
For i = lstLista.ListItems.Count To 1 Step -1
If CDate(lstLista.ListItems(i).SubItems(5)) < datai.Value Then
lstLista.ListItems.Remove i
ElseIf CDate(lstLista.ListItems(i).SubItems(5)) > dataf.Value Then
lstLista.ListItems.Remove i
End If
Next
End Sub
' É AQUI ONDE EU GOSTARIA DE INSERIR O CÓDIGO PARA PEGAR OS DADOS DO LISTVIEW E GERAR UMA NOVA PLANILHA E ENTÃO ENVIAR ESTES DADOS PARA O FORMULÁRIO DE PESQUISA
' Carrega o cadastro selecionado no formulário de consulta de cadastro
Private Sub lstLista_DblClick()
Dim linha, Index
Dim i As Integer
Dim oList As Object
Dim indiceRegistro As Long
Set oList = lstLista.SelectedItem
If oList Is Nothing Then
Exit Sub
Else
indiceRegistro = cmsCadastro.ProcuraIndiceRegistroPodId(lstLista.ListItems.Item(lstLista.SelectedItem.Index))
If indiceRegistro <> -1 Then
Call cmsCadastro.CarregaRegistroPorIndice(indiceRegistro)
End If
Unload Me
cmsCadastro.Show
End If
End Sub
E este é o código do formulário de consulta de cadastro:
Option Explicit
Const colIdeiaN As Integer = 1
Const colNome As Integer = 2
Const colFuncao As Integer = 3
Const colSetor As Integer = 4
Const colEmail As Integer = 5
Const colData As Integer = 6
Const colIdeia As Integer = 7
Const colExplicacao As Integer = 8
Const colExpectativa As Integer = 9
Const colComentarioG As Integer = 10
Const colValidacao As Integer = 11
Const colComentarioA As Integer = 12
Const colFeedBack As Integer = 13
Const indiceMinimo As Byte = 2
Const nomePlanilhaCadastro As String = "Dados"
Private wsCadastro As Worksheet
Private indiceRegistro As Long
' Procedimentos Iniciais
Private Sub UserForm_Initialize()
Call DefinePlanilhaDados
Call LimpaRegistro
validacao.AddItem "Aprovado"
validacao.AddItem "Banco de Ideias"
validacao.AddItem "Aguardando análise da Comissão"
validacao.ListIndex = 2
End Sub
' Abre Pesquisa
Private Sub npesquisa_Click()
Call LimpaRegistro
Unload Me
cmsPesquisa.Show
End Sub
Private Sub fechar_Click()
Unload cmsCadastro
End Sub
Private Sub LimpaRegistro()
'limpa os dados ao abrir o form
ideian.Value = ""
nome.Value = ""
funcao.Value = ""
setor.Value = ""
mail.Value = ""
data.Value = ""
ideia.Value = ""
explicacao.Value = ""
expectativa.Value = ""
comentario.Value = ""
validacao.Value = ""
comentariosad.Value = ""
feedback.Value = ""
End Sub
Private Sub CarregaRegistro()
'carrega os dados do primeiro registro
With wsCadastro
If Not IsEmpty(.Cells(indiceRegistro, colIdeiaN)) Then
Me.ideian.Text = .Cells(indiceRegistro, colIdeiaN).Value
Me.nome.Text = .Cells(indiceRegistro, colNome).Value
Me.funcao.Text = .Cells(indiceRegistro, colFuncao).Value
Me.setor.Text = .Cells(indiceRegistro, colSetor).Value
Me.mail.Text = .Cells(indiceRegistro, colEmail).Value
Me.data.Text = .Cells(indiceRegistro, colData).Value
Me.ideia.Text = .Cells(indiceRegistro, colIdeia).Value
Me.explicacao.Text = .Cells(indiceRegistro, colExplicacao).Value
Me.expectativa.Text = .Cells(indiceRegistro, colExpectativa).Value
Me.comentario.Text = .Cells(indiceRegistro, colComentarioG).Value
Me.validacao.Text = .Cells(indiceRegistro, colValidacao).Value
Me.comentariosad.Text = .Cells(indiceRegistro, colComentarioA).Value
Me.feedback.Text = .Cells(indiceRegistro, colFeedBack).Value
End If
End With
End Sub
Public Sub CarregaRegistroPorIndice(ByVal indice As Long)
'carrega os dados do registro baseado no índice
indiceRegistro = indice
Call CarregaRegistro
End Sub
Public Function ProcuraIndiceRegistroPodId(ByVal id As Long) As Long
Dim i As Long
Dim retorno As Long
Dim encontrado As Boolean
i = indiceMinimo
With wsCadastro
Do While Not IsEmpty(.Cells(i, colIdeiaN))
If .Cells(i, colIdeiaN).Value = id Then
retorno = i
encontrado = True
Exit Do
End If
i = i + 1
Loop
End With
'caso não encontre o registro, retorna -1
If Not encontrado Then
retorno = -1
End If
ProcuraIndiceRegistroPodId = i
End Function
Private Sub DefinePlanilhaDados()
Set wsCadastro = Worksheets(nomePlanilhaCadastro)
End Sub
Private Sub salvar_Click()
Call SalvaRegistro(CLng(ideian.Text), indiceRegistro)
End Sub
Private Sub SalvaRegistro(ByVal id As Long, ByVal indice As Long)
With wsCadastro
.Cells(indice, colIdeiaN).Value = id
.Cells(indice, colValidacao).Value = Me.validacao.Text
.Cells(indice, colComentarioA).Value = Me.comentariosad.Text
.Cells(indice, colFeedBack).Value = Me.feedback.Text
End With
'Salva o arquivo
ActiveWorkbook.Save
End Sub
Private Sub btnAnterior_Click()
If indiceRegistro > indiceMinimo Then
indiceRegistro = indiceRegistro - 1
End If
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub btnPrimeiro_Click()
indiceRegistro = indiceMinimo
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub btnProximo_Click()
If indiceRegistro < wsCadastro.UsedRange.Rows.Count Then
indiceRegistro = indiceRegistro + 1
End If
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub btnUltimo_Click()
indiceRegistro = wsCadastro.UsedRange.Rows.Count
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Após o fechamento deste formulário eu preciso que os dados da planilha temporária sejam apagados
Desde já, obrigado pela ajuda
Postado : 13/04/2015 6:01 am