Vídeo recomendado
https://youtu.be/diWPPPhW-9E
https://youtu.be/diWPPPhW-9E
modelos de sistema - gestão de clinica.
Re: modelos de sistema - gestão de clinica.
como consigo colocar formula na coluna do access de modo que logicamente calcula automaticcamnte e atualiza.
eu tenho 4 colunas
status funcionario = ativo/ inativo
ultimo exame = data
tempo corrido = DIAS360(ultimo exame;HOJE()))
status validade exame = SE(status funcionario="INATIVO";"INATIVO";(SE(tempo corrido >365;"VENCIDO";"NO PRAZO"))
podem me ajudar. gostaria mto que isso acontece no access.
quanto a questão anterior eu consegui resolver o problema só não entendi o motivo de dar o erro. eu gostaria de aprender.
sabedoria é muito nessa vida.
eu tenho 4 colunas
status funcionario = ativo/ inativo
ultimo exame = data
tempo corrido = DIAS360(ultimo exame;HOJE()))
status validade exame = SE(status funcionario="INATIVO";"INATIVO";(SE(tempo corrido >365;"VENCIDO";"NO PRAZO"))
podem me ajudar. gostaria mto que isso acontece no access.
quanto a questão anterior eu consegui resolver o problema só não entendi o motivo de dar o erro. eu gostaria de aprender.
sabedoria é muito nessa vida.
Re: modelos de sistema - gestão de clinica.
Vou disponibilizar um código que adaptei para que um calculo seja colocado direto no listview, no lugar de inserir a informação no access (eu não consegui colocar formulas lá)
Código: Selecionar todos
Option Explicit
Global db As New ADODB.Connection
Global RS As New ADODB.Recordset
Global PETH As String
Sub CONECTADB()
Set db = New ADODB.Connection
With db
.Provider = "Microsoft.ACE.OLEDB.16.0"
.ConnectionString = "Data Source=" & ThisWorkbook.Path & "\cadastro.accdb"
.Open
End With
End Sub
Sub fechadb()
db.Close: Set db = Nothing
Set RS = Nothing
End Sub
Sub LIST_PACIENTES()
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
With F_1.ListView2
With .ColumnHeaders
.Clear
'adiciona colunas
.Add , , "COD", 25 '1
.Add , , "EMPRESA", 200, 0
.Add , , "NOME", 200, 0 '2
.Add , , "DOC", 50, 0 '3
.Add , , "NUMERO", 120, 0 '4
.Add , , "STATUS DO EXAME", 100, 0 '5
End With
.View = 3 'exibir em modo de relatório
End With
sql = "SELECT * FROM PACIENTES"
'define a conexão e abre o Recordset com os dados da tabela empresa
Call CONECTADB
'*carrega lista de dados
Set RS = New ADODB.Recordset
RS.Open sql, db, 3, 3
On Error Resume Next
'Preenche o controle listview com os dados da tabela
F_1.ListView2.ListItems.Clear
While Not RS.EOF
Set list = F_1.ListView2.ListItems.Add(Text:=RS(0))
If Not IsNull(RS(11)) Then
list.SubItems(1) = RS(11)
End If
If Not IsNull(RS(1)) Then
list.SubItems(2) = RS(1)
End If
If Not IsNull(RS(3)) Then
list.SubItems(3) = RS(3)
End If
If Not IsNull(RS(4)) Then
list.SubItems(4) = RS(4)
End If
If RS(9) = "Ativo" And RS(18) <> "" And Now() - RS(18) < 365 Then
list.SubItems(5) = "no prazo"
ElseIf RS(9) = "Ativo" And RS(18) <> "" And Now() - RS(18) > 365 Then
list.SubItems(5) = "Vencido"
ElseIf RS(9) = "Inativo" Then
list.SubItems(5) = "Inativo"
End If
RS.MoveNext
Wend
'desconectar
Call fechadb
F_1.Label51 = F_1.ListView2.ListItems.Count
'habilitar novamente
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
- Reinaldo
- Jedi
- Mensagens: 1537
- Registrado em: Sex Ago 01, 2014 4:09 pm
- Localização: Garça - SP / SCS - SP
Re: modelos de sistema - gestão de clinica.
"...com banco de dados fechado..."
Como sua rotina e bem segmentada, ao efetuar as checagens diversas a conexão com o BD e aberta e fechada constantemente. Em uma das sub rotinas o BD e fechado e retorna para a rotina inicial para fechar o bd, gerando o erro. Não pude precisar exatamente o ponto, pois seu projeto tem referencia a formulario e sub rotinas que não estão presente nesse modelo, o que dificulta o acompanhamento;
mas por ser no fechamento do BD uma solução:
"...onde vai adicionar novo registro..."
Aqui não entendi a demanda, se é ao abrir a tabela access e logo abaixo do ultimo registro fica uma linha com 0, isso e padrão do BD, e não afeta em nada inclusão/verificação.
Porem é preciso atentar que como deixou o campo Id manual, a primeira inclusão se não especificada ira incluir o registo como Id=0 )Zero. Veja o registro Ortoclinic na tbl Empresa
Como sua rotina e bem segmentada, ao efetuar as checagens diversas a conexão com o BD e aberta e fechada constantemente. Em uma das sub rotinas o BD e fechado e retorna para a rotina inicial para fechar o bd, gerando o erro. Não pude precisar exatamente o ponto, pois seu projeto tem referencia a formulario e sub rotinas que não estão presente nesse modelo, o que dificulta o acompanhamento;
mas por ser no fechamento do BD uma solução:
Código: Selecionar todos
Sub fechadb()
On Error Resume Next
db.Close: Set db = Nothing
Set RS = Nothing
End Sub
"...onde vai adicionar novo registro..."
Aqui não entendi a demanda, se é ao abrir a tabela access e logo abaixo do ultimo registro fica uma linha com 0, isso e padrão do BD, e não afeta em nada inclusão/verificação.
Porem é preciso atentar que como deixou o campo Id manual, a primeira inclusão se não especificada ira incluir o registo como Id=0 )Zero. Veja o registro Ortoclinic na tbl Empresa
- Reinaldo
- Jedi
- Mensagens: 1537
- Registrado em: Sex Ago 01, 2014 4:09 pm
- Localização: Garça - SP / SCS - SP
Re: modelos de sistema - gestão de clinica.
"...como consigo colocar formula na coluna do access de modo..."
Há na definição de tipo do campo na tabela access (modo design) onde define texto/numero... um tipo considerado "Calculado", que ao ser selecionado abre o construtor de expressões.
Nota: Usualmente não é recomendado incluir campo calculado no BD, esse calculo preferencialmente deve ser efetuado nas consultas/seleçao/relatorios
Há na definição de tipo do campo na tabela access (modo design) onde define texto/numero... um tipo considerado "Calculado", que ao ser selecionado abre o construtor de expressões.
Nota: Usualmente não é recomendado incluir campo calculado no BD, esse calculo preferencialmente deve ser efetuado nas consultas/seleçao/relatorios
Re: modelos de sistema - gestão de clinica.
Caro Reinaldo tem me ajudado muito e sei que vou pedir mais ajuda. obrigada pela força.
eu preciso de uma macro eu preciso que seja pesquisado na COLUNA a referencia onde devo salvar a informação.
criei uma macro para meu excel sub exames e queria adaptar para gravar a informação no acces mas não sei como seria essa adapação.
se não tiver jeito de criar macro para essa função. será que consigo usar a macro que esta logo abaixo chamado Sub fncMain() de uma analizada nela e pode me ensinar. quero entender se ela abre a pasta de destino e salva e depois fecha igual do access. ou não.
eu preciso de uma macro eu preciso que seja pesquisado na COLUNA a referencia onde devo salvar a informação.
criei uma macro para meu excel sub exames e queria adaptar para gravar a informação no acces mas não sei como seria essa adapação.
se não tiver jeito de criar macro para essa função. será que consigo usar a macro que esta logo abaixo chamado Sub fncMain() de uma analizada nela e pode me ensinar. quero entender se ela abre a pasta de destino e salva e depois fecha igual do access. ou não.
Código: Selecionar todos
Sub exames()
'F_2.Abox7.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA) = F_2.Abox7.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox8.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA) = F_2.Abox8.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox9.Valuue
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox9.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox10.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox10.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox11.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox11.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox12.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox12.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox13.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox13.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox14.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox14.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox15.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox15.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox16.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox16.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox17.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox17.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox18.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox18.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox19.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox19.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox20.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox20.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox21.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox21.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox22.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox22.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox23.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox23.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox24.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox24.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
End Sub
Código: Selecionar todos
Sub fncMain()
Dim lngLastLin As Long
Dim wksOri As Worksheet
Dim wkbDes As Workbook
Dim wksDes As Worksheet
Set wksOri = ThisWorkbook.Worksheets("PlanOrigem")
Set wkbDes = Workbooks.Open("c:\temp\Destino.xlsm")
Set wksDes = wkbDes.Worksheets("PlanDestino")
With wksDes
lngLastLin = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
wksDes.Cells(lngLastLin, 1) = wksOri.Range("A1")
wkbDes.Close SaveChanges:=True
End Sub
- Reinaldo
- Jedi
- Mensagens: 1537
- Registrado em: Sex Ago 01, 2014 4:09 pm
- Localização: Garça - SP / SCS - SP
Re: modelos de sistema - gestão de clinica.
Não entendi o objetivo da Sub Exames; principalmente o trecho abaixo que se repete varias vezes
Pode fornecer maiores detalhes e em que tabela do access espera/precisa/deseja ter algo similar
"...quero entender se ela abre...
Veja se os comentários ajudam
Código: Selecionar todos
For COLUNA = 17 To 40
Next COLUN
"...quero entender se ela abre...
Veja se os comentários ajudam
Código: Selecionar todos
Sub fncMain()
Dim wksOri As Worksheet
Dim wkbDes As Workbook
Dim wksDes As Worksheet
'Atribui as variaveis Worksheet sua referencia
Set wksOri = ThisWorkbook.Worksheets("PlanOrigem")
Set wkbDes = Workbooks.Open("c:\temp\Destino.xlsm")
Set wksDes = wkbDes.Worksheets("PlanDestino")
'Acrescenta o valor de A1 da planilha origem para a planilha destino
With wksDes
wksDes.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1) = wksOri.Range("A1")
End With
'Fecha planilha destino
wkbDes.Close SaveChanges:=True
End Sub
Re: modelos de sistema - gestão de clinica.
Reinaldo escreveu: ↑Ter Ago 13, 2019 4:03 pm Não entendi o objetivo da Sub Exames; principalmente o trecho abaixo que se repete varias vezesPode fornecer maiores detalhes e em que tabela do access espera/precisa/deseja ter algo similarCódigo: Selecionar todos
For COLUNA = 17 To 40 Next COLUN
"...quero entender se ela abre...
Veja se os comentários ajudamCódigo: Selecionar todos
Sub fncMain() Dim wksOri As Worksheet Dim wkbDes As Workbook Dim wksDes As Worksheet 'Atribui as variaveis Worksheet sua referencia Set wksOri = ThisWorkbook.Worksheets("PlanOrigem") Set wkbDes = Workbooks.Open("c:\temp\Destino.xlsm") Set wksDes = wkbDes.Worksheets("PlanDestino") 'Acrescenta o valor de A1 da planilha origem para a planilha destino With wksDes wksDes.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1) = wksOri.Range("A1") End With 'Fecha planilha destino wkbDes.Close SaveChanges:=True End Sub
está em anexo o sistema inicial da clinica
senha para adm é davi2020
no f_02 (formulário pacientes) quando vou fazer novo atendimento. as combox nele tem os exames que fazemos.
exemplo se tal pessoa vai ser atendido e realiza exame clinico. (da combobox) no registro vai procurar a coluna correspondente a exame clinico e salva como n° 1 na (linha, coluna correspondente) e assim por diantes.
cada exame tem sua coluna correspondente.
por isso criado a macro sub exame.
lógico não sou master em programação fui testando e testando saiu essa mesmo grande. se tiver comoreduzir ela para mim fico mto grata.
e olha to super feliz que eu esteja conseguindo aprender com vcs. consegui fazer o sql com excell e agora vai...
- Anexos
-
- saudetrab.zip
- (2.22 MiB) Baixado 900 vezes
Re: modelos de sistema - gestão de clinica.
oi boa noite tudo bem?
estou com um problema no procedimento salvar_atualizar_exames
e no atualizar _exames
não está reconhecendoo if.. mesmo que a referencia seja igual ao item selecionado não reconhece asssim não atualiza minhas informações.
é normal tbm quando salvar em outra pasta de trabalho. ficar piscando a tela?
um grande abraço e otima quarta feira.
estou com um problema no procedimento salvar_atualizar_exames
e no atualizar _exames
não está reconhecendoo if.. mesmo que a referencia seja igual ao item selecionado não reconhece asssim não atualiza minhas informações.
é normal tbm quando salvar em outra pasta de trabalho. ficar piscando a tela?
um grande abraço e otima quarta feira.
Código: Selecionar todos
Global lngLastLin As Long
Global wkbDes As Workbook
Global wksDes As Worksheet
Global OBS As String
Global i As Integer
Global Data As Date
Global maximo As Integer
Global LINHA As Byte
Global coluna As Byte
Sub SALVAR_ATUALIZAR_EXAMES()
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
'=========salvar_atualizar
Dim resultado As VbMsgBoxResult
sql = "SELECT * FROM c_exame " & " WHERE código like '" & F_2.cod5.Value & "'"
'define a conexão e abre o Recordset com os dados da tabela empresa
Call CONECTADB
'*carrega lista de dados
Set RS = New ADODB.Recordset
RS.Open sql, db, 3, 3
If F_2.cod5.Value <> "" And F_2.cod5.Value = RS(0) Then
resultado = MsgBox("cadastro existente no Código " & RS(0) & ", deseja atualizar ", vbYesNo, "atualizar")
If resultado = vbYes Then
Call fechadb
Call ATUALIZAR_EXAMES
Exit Sub
End If
Exit Sub
End If
Call fechadb
'Call SALVAR_EXAMES
'=========fim salvar atualizar
'habilitar novamente
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub SALVAR_EXAMES()
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo Aviso
Data = F_2.Abox1.Value
OBS = F_2.ALTURA.Value & " " & F_2.CONFINAMENTO.Value & " " & F_2.VEICULOS.Value
Set wkbDes = Workbooks.Open(ThisWorkbook.Path & "\CADASTRO DE ATENDIMENTOS.xlsx")
Set wksDes = wkbDes.Worksheets("c_exame")
wksDes.Application.Visible = False
maximo = Application.WorksheetFunction.Max(wksDes.Range("A:A"))
F_2.cod5 = maximo + 1
With wksDes
lngLastLin = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
wksDes.Cells(lngLastLin, 1) = F_2.cod5.Value
wksDes.Cells(lngLastLin, 2) = F_2.cod2.Value
wksDes.Cells(lngLastLin, 3) = F_2.cod3.Value
wksDes.Cells(lngLastLin, 4) = F_2.Abox3.Text
wksDes.Cells(lngLastLin, 5) = F_2.Abox31.Text
wksDes.Cells(lngLastLin, 6) = F_2.Abox5.Text
wksDes.Cells(lngLastLin, 7) = F_2.TextBox2.Text
wksDes.Cells(lngLastLin, 8) = DateValue(Data)
wksDes.Cells(lngLastLin, 9) = F_2.box11.Text
wksDes.Cells(lngLastLin, 10) = F_2.box12.Text
wksDes.Cells(lngLastLin, 11) = F_2.Abox26.Text
wksDes.Cells(lngLastLin, 12) = F_2.box1.Text
wksDes.Cells(lngLastLin, 13) = OBS
wksDes.Cells(lngLastLin, 15) = F_2.Abox30.Text
'==================== para atendimentos
Call exames
' fechar
wksDes.Application.Visible = True
wkbDes.Close SaveChanges:=True
Call salvarultimoexame
Call FILTRO_ATENDIMENTO_PACIENTE
MsgBox "Dados Gravados com Sucesso" & " id n° " & F_2.cod5.Value
Exit Sub
Aviso: MsgBox "PASTA ABERTA POR OUTRO USUÁRIO OU NÃO ENCONTRADA NO DESTINO " & ThisWorkbook.Path & "\CADASTRO DE ATENDIMENTOS.xlsx"
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub ATUALIZAR_EXAMES()
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
'On Error Resume Next
Dim resultado As VbMsgBoxResult
Data = F_2.Abox1.Value
LINHA = 1
coluna = 17
Dim valorpesquisa
valorpesquisa = F_2.cod5.Value
OBS = F_2.ALTURA.Value & " " & F_2.CONFINAMENTO.Value & " " & F_2.VEICULOS.Value
Set wkbDes = Workbooks.Open(ThisWorkbook.Path & "\CADASTRO DE ATENDIMENTOS.xlsx")
Set wksDes = wkbDes.Worksheets("c_exame")
Do Until wksDes.Cells(LINHA, 1) = "" 'vai executar o laço até encontrar uma célula vazia
'condicção para localizar o registro
If wksDes.Cells(LINHA, 1) = valorpesquisa Then 'se encontrar o valor registro na célula pesquisada
wksDes.Cells(LINHA, 1) = F_2.cod5.Value
wksDes.Cells(LINHA, 2) = F_2.cod2.Value
wksDes.Cells(LINHA, 3) = F_2.cod3.Value
wksDes.Cells(LINHA, 4) = F_2.Abox3.Text
wksDes.Cells(LINHA, 5) = F_2.Abox31.Text
wksDes.Cells(LINHA, 6) = F_2.Abox5.Text
wksDes.Cells(LINHA, 7) = F_2.TextBox2.Text
wksDes.Cells(LINHA, 8) = DateValue(Data)
wksDes.Cells(LINHA, 9) = F_2.box11.Text
wksDes.Cells(LINHA, 10) = F_2.box12.Text
wksDes.Cells(LINHA, 11) = F_2.Abox26.Text
wksDes.Cells(LINHA, 12) = F_2.box1.Text
wksDes.Cells(LINHA, 13) = OBS
wksDes.Cells(LINHA, 15) = F_2.Abox30.Text
'limpar exames
For coluna = 17 To 40
wksDes.Cells(LINHA, coluna) = ""
Next coluna
' preencher dados
Call exames
Call salvarultimoexame
' fechar
wkbDes.Close SaveChanges:=True
Call FILTRO_ATENDIMENTO_PACIENTE
MsgBox "Dados Alterado com Sucesso" & " id n° " & F_2.cod5.Value
Else
wkbDes.Close SaveChanges:=True
Exit Sub
End If
LINHA = LINHA + 1
Loop
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub exames()
Set wkbDes = Workbooks.Open(ThisWorkbook.Path & "\CADASTRO DE ATENDIMENTOS.xlsx")
Set wksDes = wkbDes.Worksheets("c_exame")
'F_2.Abox7.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna) = F_2.Abox7.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox8.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna) = F_2.Abox8.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox9.Valuue
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox9.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox10.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox10.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox11.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox11.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox12.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox12.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox13.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox13.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox14.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox14.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox15.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox15.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox16.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox16.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox17.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox17.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox18.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox18.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox19.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox19.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox20.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox20.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox21.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox21.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox22.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox22.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox23.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox23.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox24.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox24.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
End Sub
Sub salvarultimoexame()
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo Aviso
' salvar ultimo exame no cadastro
Dim valorpesquisa
valorpesquisa = F_2.cod3.Value
sql = "SELECT * FROM PACIENTES where COD like '" & valorpesquisa & "'"
Call CONECTADB
'*carrega lista de dados
Set RS = New ADODB.Recordset
RS.Open sql, db, 3, 3
'On Error Resume Next
'salva
RS.Update
If F_2.op2 = True Then
RS!situação = "Inativo"
Else
RS!situação = "Ativo"
End If
RS!U_consulta = F_2.Abox1
RS.Update
'desconectar
Call fechadb
Exit Sub
Aviso: MsgBox "Paciente não Cadastrado"
'habilitar novamente
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub exportar_guia()
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
Static wod1 As Word.Application
Static wod1Doc As Word.Document
Set wod1 = New Word.Application
Set wod1Doc = wod1.Documents.Add(ThisWorkbook.Path & "\Guia de Encaminhamento.docx")
With wod1Doc
.FormFields("WD1").Range = F_2.Abox5.Text 'ENCAMINHAMENTO
.FormFields("WD2").Range = F_2.Abox1.Text 'DATA
.FormFields("WD3").Range = F_2.box11.Text 'EMPRESA
.FormFields("WD4").Range = F_2.box1.Text 'NOME DO PACIENTE
.FormFields("WD5").Range = F_2.box5.Text 'DN
.FormFields("WD6").Range = F_2.box4.Text 'DOC
.FormFields("WD7").Range = F_2.Abox26.Text 'TIPO DE EXAME
.FormFields("WD8").Range = F_2.box12.Text 'FUNÇÃO
.FormFields("WD9").Range = F_2.Abox7.Text
.FormFields("WD10").Range = F_2.Abox8.Text
.FormFields("WD11").Range = F_2.Abox9.Text
.FormFields("WD12").Range = F_2.Abox10.Text
.FormFields("WD13").Range = F_2.Abox11.Text
.FormFields("WD14").Range = F_2.Abox12.Text
.FormFields("WD15").Range = F_2.Abox13.Text
.FormFields("WD16").Range = F_2.Abox14.Text
.FormFields("WD17").Range = F_2.Abox15.Text
.FormFields("WD18").Range = F_2.Abox16.Text
.FormFields("WD19").Range = F_2.Abox17.Text
.FormFields("WD20").Range = F_2.Abox18.Text
.FormFields("WD21").Range = F_2.Abox19.Text
.FormFields("WD22").Range = F_2.Abox20.Text
.FormFields("WD23").Range = F_2.Abox21.Text
.FormFields("WD24").Range = F_2.Abox22.Text
.FormFields("WD25").Range = F_2.Abox23.Text
.FormFields("WD26").Range = F_2.Abox24.Text
wod1.Visible = True
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub exportar_exame()
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
Dim OBS As String
OBS = F_2.ALTURA.Value & " " & F_2.CONFINAMENTO.Value & " " & F_2.VEICULOS.Value
Static wod1 As Word.Application
Static wod1Doc As Word.Document
Set wod1 = New Word.Application
Set wod1Doc = wod1.Documents.Add(ThisWorkbook.Path & "\ASO.docx")
With wod1Doc
.FormFields("WD27").Range = FormatDateTime(F_2.Abox1, vbLongDate) 'DATA
.FormFields("WD1").Range = F_2.box11.Text 'EMPRESA
.FormFields("WD2").Range = F_2.box1.Text 'NOME DO PACIENTE
.FormFields("WD3").Range = F_2.box4.Text 'DOC
.FormFields("WD4").Range = F_2.box6.Text 'idade
.FormFields("WD5").Range = F_2.box5.Text 'DN
.FormFields("WD6").Range = F_2.box12.Text 'FUNÇÃO
.FormFields("wd29").Range = F_2.box3.Text 'tipo doc
.FormFields("WD28").Range = F_2.TextBox1.Text 'setor
.FormFields("WD7").Range = F_2.Abox26.Text 'TIPO DE EXAME
.FormFields("WD8").Range = OBS 'observações
.FormFields("WD9").Range = F_2.Abox7.Text
.FormFields("WD10").Range = F_2.Abox8.Text
.FormFields("WD11").Range = F_2.Abox9.Text
.FormFields("WD12").Range = F_2.Abox10.Text
.FormFields("WD13").Range = F_2.Abox11.Text
.FormFields("WD14").Range = F_2.Abox12.Text
.FormFields("WD15").Range = F_2.Abox13.Text
.FormFields("WD16").Range = F_2.Abox14.Text
.FormFields("WD17").Range = F_2.Abox15.Text
.FormFields("WD18").Range = F_2.Abox16.Text
.FormFields("WD19").Range = F_2.Abox17.Text
.FormFields("WD20").Range = F_2.Abox18.Text
.FormFields("WD21").Range = F_2.Abox19.Text
.FormFields("WD22").Range = F_2.Abox20.Text
.FormFields("WD23").Range = F_2.Abox21.Text
.FormFields("WD24").Range = F_2.Abox22.Text
.FormFields("WD25").Range = F_2.Abox23.Text
.FormFields("WD26").Range = F_2.Abox24.Text
wod1.Visible = True
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub limpar_atendimento()
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
F_2.op1 = False
F_2.op2 = False
F_2.op3 = False
F_2.op4 = False
F_2.op5 = False
F_2.acheck1 = False
F_2.acheck2 = False
F_2.aCheck3 = False
F_2.Abox7 = ""
F_2.Abox8 = ""
F_2.Abox9 = ""
F_2.Abox10 = ""
F_2.Abox11 = ""
F_2.Abox12 = ""
F_2.Abox13 = ""
F_2.Abox14 = ""
F_2.Abox15 = ""
F_2.Abox16 = ""
F_2.Abox17 = ""
F_2.Abox18 = ""
F_2.Abox19 = ""
F_2.Abox20 = ""
F_2.Abox21 = ""
F_2.Abox22 = ""
F_2.Abox23 = ""
F_2.Abox24 = ""
F_2.Abox26 = ""
'habilitar novamente
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
- Anexos
-
- SaudeTRAB.zip
- (1.51 MiB) Baixado 860 vezes