Alimentando tabela ...
 
Notifications
Clear all

Alimentando tabela referenciada com formulario VBA

14 Posts
2 Usuários
0 Reactions
3,354 Visualizações
(@spiders)
Posts: 0
New Member
Topic starter
 

Boa tarde prezados

Eu fiz um formulário para alimentar uma tabela que será a base de dados. Eu vi na internet a fórmula para a macro sempre selecionar a ultima linha para inserir as proximas informações, seria esse o código:

linha = Sheets(“BASE”).Cells(Rows.Count, “E”).End(xlUp).Offset(1, 0).Row
Sheet3.Cells(linha, 5).Value = Me.txtData.Value
Sheet3.Cells(linha, 6).Value = Me.txtHorario.Value
Sheet3.Cells(linha, 7).Value = Me.txtNome.Value
Sheet3.Cells(linha, 8).Value = Me.txtRamal.Value
Sheet3.Cells(linha, 9).Value = Me.txtAssunto.Value

Mas o formulário não preenche a tabela que já existe na planilha. Ele pega a primeira célula que não possui informações e seleciona ela. Eu gostaria que ele selecionasse dentro da tabela, mas essa linha esta selecionando a primeira célula depois da tabela criada.
O cadastro está ficando abaixo da planilha como mostra o print:

Qual seria o código para usar a minha tabela de nome AgendadordeEventos como a base de dados do formulário?

 
Postado : 11/10/2019 10:44 am
(@srobles)
Posts: 0
New Member
 

spiders,

Altere a seguinte linha

linha = Sheets(“BASE”).Cells(Rows.Count, “E”).End(xlUp).Offset(1, 0).Row

Para :

linha = ThisWorkBook.Sheets(“AgendadordeEventos”).Cells(Rows.Count, “E”).End(xlUp).Row + 1
 
Postado : 11/10/2019 11:53 am
(@spiders)
Posts: 0
New Member
Topic starter
 

Boa tarde, eu fiz a alteração na linha, porém retornou o seguinte erro

Erro em tempo de execução '9':
Subscrito fora do intervalo

 
Postado : 11/10/2019 1:18 pm
(@srobles)
Posts: 0
New Member
 

spiders,

Na sua pasta de trabalho, qual o nome da guia que serve como Base de dados? AgendadordeEventos ou BASE?

Apenas altere isso na linha que faz referência á guia que é sua base de dados.

 
Postado : 11/10/2019 1:48 pm
(@spiders)
Posts: 0
New Member
Topic starter
 

Bom dia, a guia se chama "Base", mas a tabela se chama "AgendadorDeEventos".

Obrigado

 
Postado : 14/10/2019 5:31 am
(@srobles)
Posts: 0
New Member
 

spiders,

Se puder, suba seu modelo em sites de compartilhamento como, sendspace, google drive etc... e disponibilize o link para que possamos analisar e tentar auxiliá-lo.
Para postar o link, use a ferramenta URL "linkdoarquivo" sem aspas.

 
Postado : 14/10/2019 10:39 am
(@spiders)
Posts: 0
New Member
Topic starter
 

Bom dia muito obrigado pela sua contribuição, agora a caixa de confinação está funcionando. Mas gostaria de quando eu finalizasse o cadastro, assim como as caixas de texto ficaram limpas, a caixa de combinação também ficasse em branco. Outro detalhe que continuo com problema é esse abaixo conforma a imagem:

Quando eu uso o formulário em VB para fazer o agendamento, na primeira linha a coluna "VALOR CALCULADO" fica formatado como data. Se essa coluna ficar formatada desse jeito as formulas na planilha não funciona. Quando eu cadastro manualmente uma data na tabela essa coluna "VALOR CALCULADO" fica formatado somente número e assim todas as fórmulas funcionam. O problema é que não sei o que está fazendo isso acontecer, porque todas as células dentro da tabela estão formatadas corretamente. O curioso é que se eu clico duas vezes na célula "data" da primeira linha que foi preenchida com o vba e depois desselecionar a célula, a celula da coluna "VALOR CALCULADO" fica formatada corretamente.

 
Postado : 18/10/2019 5:59 am
(@srobles)
Posts: 0
New Member
 

Spiders,

Para limpar o ComboBox, deixei algumas linhas comentadas no código que insere os dados na guia. Altere esta linha Me.ComboBox1.RemoveItem Me.ComboBox1.ListIndex para Me.ComboBox1 = "" e veja se tem o resultado desejado.

Na questão que se refere ao campo VALOR CALCULADO, a data deve entrar na guia como Data mesmo? Caso positivo (pois notei que se for dessa maneira), este campo ficaria com o valor ex: 4355|1), altere esta linha Sheet3.Cells(linha, 5).Value = Me.txtData.Value para Sheet3.Cells(linha, 5).Value = CDate(Me.txtData.Value). Assim o campo VALOR CALCULADO retornará o valor nesse formato.

 
Postado : 18/10/2019 9:28 am
(@spiders)
Posts: 0
New Member
Topic starter
 

Muito obrigado!! Era isso mesmo que estava acontecendo. Fiz a alteração que você recomendou e a coluna valor exclusivo agora está sendo formatada conforme o necessário.

 
Postado : 21/10/2019 7:03 am
(@spiders)
Posts: 0
New Member
Topic starter
 

Muito obrigado, era isso mesmo que eu estava precisando. Agora tenho mais um detalhe pra deixar a planilha do jeito que estou precisando. Como faço para não deixar meu formulário fazer um agendamento repetido, ou seja, caso a minha tabela já esteja preenchida com data e hora que alguém esteja tentando cadastrar novamente, eu preciso de uma condições que bloqueie isso. Como seria possível? Prometo que essa será a última dúvida do tópico, acredito que estou fazendo errado tirando várias dúvidas que não estão no tema do título.

Desde já agradeço a ajuda.

 
Postado : 21/10/2019 8:17 am
(@srobles)
Posts: 0
New Member
 

spiders,

Na janela de código do Userform, adicione logo na primeira linha :

Dim existeAgendamento As Boolean

No código do botão de cadastro, adicione as linhas abaixo antes da rotina que efetua o cadastro :

    Call validaAgendamento(CStr(Me.txtData), CStr(Me.cboHora))
    
    If existeAgendamento = True Then
        MsgBox "Data e Hora já utilizados em outro agendamento!", vbExclamation, "Erro"
        Exit Sub
    End If

E por fim, pode ser ao final dos códigos do UserForm, adicione a Function abaixo :

Function validaAgendamento(ByVal Data As String, ByVal Hora As String)
    
    existeAgendamento = False
    
    With ThisWorkbook.Sheets("Base")
        Dim vData As String, vHora As String
        Dim linhaAtual As Long
        
        linhaAtual = 3
        
        Do
            vData = CStr(.Cells(linhaAtual, 5))
            vHora = Format(.Cells(linhaAtual, 6), "h:mm")
            
            If vData = CStr(Data) Then
                If vHora = CStr(Hora) Then
                    existeAgendamento = True
                    Exit Do
                End If
            End If
            linhaAtual = linhaAtual + 1
        Loop While .Cells(linhaAtual, 5) <> "" 'linhaAtual <= linhaFinal
        
    End With
End Function
 
Postado : 21/10/2019 3:22 pm
(@spiders)
Posts: 0
New Member
Topic starter
 

Boa tarde, eu estou recebendo um erro que me retorna a mensagem para adicionar um End Sub, porém se eu adicionar esse End Sub ele ficará no meio do código.
Segue o código abaixo:

Private Sub btnAgendar_Click()
    Dim idHora As Long
        linha = IIf(Sheets("Base").Range("AgendadordeEventos").Cells(1, 1) = "", 3, Sheets("Base").Range("AgendadordeEventos").Cells(0, 1).End(4).Row + 1)
        
        idHora = Me.cboHora.ListIndex
        'Nova rotina para validar agendamento
        Call validaAgendamento(CStr(Me.txtData), CStr(Me.cboHora))
        If existeAgendamento = True Then
            MsgBox "Data e Hora já utilizados em outro agendamento!", vbExclamation, "Erro"
            Exit Sub
        End If
        
        'Para que a data entre como texto, formate a coluna como GERAL
        'pois a linha abaixo insere o valor como TEXTO( String )
        Sheet3.Cells(linha, 5).Value = CDate(Me.txtData.Value)
        'Aqui inserimos valor com formato de Hora:Minutos
        Sheet3.Cells(linha, 6).Value = Format(Me.cboHora.Value, "hh:mm")
        Sheet3.Cells(linha, 7).Value = UCase(Me.txtNome.Value)
        Sheet3.Cells(linha, 8).Value = UCase(Me.txtRamal.Value)
        Sheet3.Cells(linha, 9).Value = UCase(Me.txtAssunto.Value)
        
        'Columns.AutoFit
        
        MsgBox "Agendamento concluído", vbInformation, "Agendamento de Reunião"
        
        Me.txtData.Value = ""
        
        'Se desejar remover o horário cadastrado da lista
        'descomente a linha abaixo
        'Me.cboHora.RemoveItem Me.cboHora.ListIndex
        
        Me.txtNome.Value = ""
        Me.cboHora.Value = ""
        Me.txtRamal.Value = ""
        Me.txtAssunto.Value = ""
        
        

End Sub

Private Sub TextBox2_Change()

End Sub

Private Sub btnSair_Click()
Unload frmAgendamentoCGH

End Sub

Private Sub cbHora_Change()

End Sub

Private Sub cboHora_Change()

End Sub

Private Sub Image1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)

End Sub

Private Sub txtData_Change()
End Sub

Private Sub txtData_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = vbKeyReturn Or KeyCode = vbKeyTab Then
        txtData = Format(txtData, "@@/@@/@@@@")
    End If
End Sub

Private Sub txtHora_Change()
End Sub

Private Sub txtHora_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = vbKeyReturn Or KeyCode = vbKeyTab Then
        txtHora = Format(txtHora, "@@:@@")
    End If
End Sub

Private Sub UserForm_Click()

End Sub

Private Sub UserForm_Initialize()
    Dim existeAgendamento As Boolean
    
    With cboHora
        .Style = fmStyleDropDownCombo
        .Clear
        
        For vLinha = 3 To ThisWorkbook.Sheets("Intervalo").Cells(Rows.Count, 5).End(xlUp).Row - 1
            If ThisWorkbook.Sheets("Intervalo").Cells(vLinha, 5) <> "" Then
                .AddItem ThisWorkbook.Sheets("Intervalo").Cells(vLinha, 5).Text
            End If
        Next
        
        .Style = fmStyleDropDownList
        .ListIndex = 0
    End With
    
    'Adicionando código para condição de agendamento
    Function validaAgendamento(ByVal Data As String, ByVal Hora As String)
        existeAgendamento = False
        
        With ThisWorkbook.Sheets3("Base")
            Dim vData As String, vHora As String
            Dim linhaAtual As Long
            
            linhaAtual = 3
            
            Do
                vData = CStr(.Cells(linhaAtual, 5))
                vHora = Format(.Cells(linhaAtual, 6), "h:mm")
                
                If vData = CStr(Data) Then
                    If vHora = CStr(Hora) Then
                        existeAgendamento = True
                        Exit Do
                    End If
                End If
                linhaAtual = linhaAtual + 1
            Loop While .Cells(linhaAtual, 5) <> "" 'linhaAtual <= linhaFinal
        End With
    End Function
End Sub

Qual seria o local correto para adicionar os códigos no UserForm?

 
Postado : 22/10/2019 11:43 am
(@srobles)
Posts: 0
New Member
 

spiders,

Se os códigos acima forem tudo o que está dentro do frmAgendamentoCGH, copie tudo para um bloco de notas (só por garantia) e remova tudo. Após isso, substitua pelo conteúdo que deixo abaixo e teste.

Dim existeAgendamento As Boolean
Private Sub btnAgendar_Click()
    Dim idHora As Long
    
    'Nova rotina para validar agendamento
    Call validaAgendamento(CStr(Me.txtData), CStr(Me.cboHora))
    
    If existeAgendamento = True Then
        MsgBox "Data e Hora já utilizados em outro agendamento!", vbExclamation, "Erro"
        Exit Sub
    End If
    
    linha = IIf(Sheets("Base").Range("AgendadordeEventos").Cells(1, 1) = "", 3, Sheets("Base").Range("AgendadordeEventos").Cells(0, 1).End(4).Row + 1)
   
    idHora = Me.cboHora.ListIndex
   
    'Para que a data entre como texto, formate a coluna como GERAL
    'pois a linha abaixo insere o valor como TEXTO( String )
    Sheet3.Cells(linha, 5).Value = CDate(Me.txtData.Value)
    'Aqui inserimos valor com formato de Hora:Minutos
    Sheet3.Cells(linha, 6).Value = Format(Me.cboHora.Value, "hh:mm")
    Sheet3.Cells(linha, 7).Value = UCase(Me.txtNome.Value)
    Sheet3.Cells(linha, 8).Value = UCase(Me.txtRamal.Value)
    Sheet3.Cells(linha, 9).Value = UCase(Me.txtAssunto.Value)
   
    'Columns.AutoFit
   
    MsgBox "Agendamento concluído", vbInformation, "Agendamento de Reunião"
   
    Me.txtData.Value = ""
   
    'Se desejar remover o horário cadastrado da lista
    'descomente a linha abaixo
    'Me.cboHora.RemoveItem Me.cboHora.ListIndex
   
    Me.txtNome.Value = ""
    Me.cboHora.Value = ""
    Me.txtRamal.Value = ""
    Me.txtAssunto.Value = ""

End Sub

Private Sub btnSair_Click()
Unload frmAgendamentoCGH

End Sub

Private Sub txtData_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = vbKeyReturn Or KeyCode = vbKeyTab Then
    txtData = Format(txtData, "@@/@@/@@@@")
End If
End Sub


Private Sub txtHora_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = vbKeyReturn Or KeyCode = vbKeyTab Then
    txtHora = Format(txtHora, "@@:@@")
End If
End Sub


Private Sub UserForm_Initialize()

    With cboHora
    .Style = fmStyleDropDownCombo
    .Clear
    
        For vLinha = 3 To ThisWorkbook.Sheets("Intervalo").Cells(Rows.Count, 5).End(xlUp).Row - 1
            If ThisWorkbook.Sheets("Intervalo").Cells(vLinha, 5) <> "" Then
                .AddItem ThisWorkbook.Sheets("Intervalo").Cells(vLinha, 5).Text
            End If
        Next
    
    .Style = fmStyleDropDownList
    .ListIndex = 0
    End With

End Sub

'Adicionando código para condição de agendamento
Function validaAgendamento(ByVal Data As String, ByVal Hora As String)
    existeAgendamento = False
   
    With ThisWorkbook.Sheets3("Base")
        Dim vData As String, vHora As String
        Dim linhaAtual As Long
       
        linhaAtual = 3
       
        Do
            vData = CStr(.Cells(linhaAtual, 5))
            vHora = Format(.Cells(linhaAtual, 6), "h:mm")
           
            If vData = CStr(Data) Then
                If vHora = CStr(Hora) Then
                    existeAgendamento = True
                    Exit Do
                End If
            End If
            linhaAtual = linhaAtual + 1
        Loop While .Cells(linhaAtual, 5) <> "" 'linhaAtual <= linhaFinal
    End With
End Function
 
Postado : 22/10/2019 12:02 pm
(@spiders)
Posts: 0
New Member
Topic starter
 

Muito obrigado, está funcionando toda a lógica da planilha. Te agradeço muito e agora vou começar a estudar mais o VB para começar a fazer mais planilhas dessa forma.
Abraços

 
Postado : 23/10/2019 8:09 am