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