Excel Enviar os dados para um BD

Sergio31 · 23 de agosto de 2022

Em 29/07/2022 às 08:40, Midori disse:
@Alexandre José Costa Antes de atualizar os valores o Calculate pode desativar os eventos com EnableEvents, veja se assim resolve o problema do travamento,
Private Sub Worksheet_Calculate()
    Dim Valor As Range
    
    Application.EnableEvents = False
    For Each Valor In [D3:D71]
        If Not IsError(Valor) Then
            If Valor.Value <> "" Then
                Call Atualiza(Valor, 5)
            End If
        End If
    Next Valor
    Application.EnableEvents = True
End Sub
Se ainda não resolver e se acha que o problema pode ser a taxa de atualização você pode tentar modificar isso com ThrottleInterval (Application.RTD.ThrottleInterval). Nas documentações diz que o intervalo de atualização do RTD é a cada 2 segundos.

https://docs.microsoft.com/en-us/office/vba/api/excel.rtd.throttleinterval

@MidoriOlá, em vez de duplicar os dados em outra coluna eu preciso enviar os dados para um BD, e com base no que você criou tentei formular algo mas não deu certo. poderia me auxiliar? No meu caso a parte da duplicação da coluna não é necessária, preciso somente do envio automático para o BD cada vez que o RTD atualizar. poderia me auxiliar, não estou conseguindo desenvolver o script.

rtd_bd.xlsx

Midori · 23 de agosto de 2022

@Sergio31 O BD é a própria planilha? Quando se refere a "enviar os dados" quer dizer que é para pegar os dados do range D9:D12 e ir acrescentando numa tabela a cada atualização?

Sergio31 · 24 de agosto de 2022

9 horas atrás, Midori disse:

@Sergio31 O BD é a própria planilha? Quando se refere a "enviar os dados" quer dizer que é para pegar os dados do range D9:D12 e ir acrescentando numa tabela a cada atualização?

A cada atualização dos range D9:D12 deve inserir os dados como texto para o BD em uma tabela que eu criei no access. as colunas que eu criei no access é a mesma do Excel . Tentei criar algo mas não funcionou.

Sub ConectaDb()

Dim cnn         As New ADODB.Connection
Dim BancoDados  As String
Dim Wbk         As Workbook
Dim Sql         As String
Dim Rs          As New ADODB.Recordset
Dim nLin        As Integer


Set Wbk = RTD

BancoDados = Wbk.Path & "F:\BD\DBace.accdb"
If cnn.State = 0 Then
    cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                       "Data Source=" & BancoDados & ";" & _
                       "Jet OLEDB:Database Password=MyDbPassword;"
    cnn.Open

End If
nLin = 9
Sql = "Select * From rtd_bd"
Rs.Open Sql, cnn, adOpenKeyset, adLockOptimistic
With RTD
    Do
        Rs!num = .Range(D9)
        Rs!hora = .Range(D10)
        Rs!preco = .Range(D11)
        Rs!qtd = .Range(D12)
        
        Rs.Update
        nLin = nLin + 1
   
    Loop Until .Range(D9) <> Range(E9)
End With
cnn.Close

Set Wbk = Nothing
End Sub

Midori · 24 de agosto de 2022

11 horas atrás, Sergio31 disse:

Rs!num = .Range(D9)
        Rs!hora = .Range(D10)
        Rs!preco = .Range(D11)
        Rs!qtd = .Range(D12)

Faltou aspas no range e se ainda tiver erro tente AddNew antes,

Rs.AddNew
Rs!num = .Range("D9")
Rs!hora = .Range("D10")
Rs!preco = .Range("D11")
Rs!qtd = .Range("D12")

Sergio31 · 29 de agosto de 2022

Em 24/08/2022 às 09:10, Midori disse:
Faltou aspas no range e se ainda tiver erro tente AddNew antes,
Rs.AddNew
Rs!num = .Range("D9")
Rs!hora = .Range("D10")
Rs!preco = .Range("D11")
Rs!qtd = .Range("D12")

@Midori Não funcionou, você consegue copiar o RTD a cada atualização! Preciso copiar e enviar para o bd access. a cada vez que atualizar, a sua logica é perfeita para isso mas eu não sei como adapta-la para o meu proposito de enviar os dados para o bd.. pode me ajudar?

Midori · 29 de agosto de 2022

@Sergio31 O que quer dizer com "não funcionou"? Acontece algum erro na sua macro? Em que parte? Dê mais detalhes e se possível anexe os arquivos.

Sergio31 · 11 de setembro de 2022

Em 29/08/2022 às 13:03, Midori disse:

@Sergio31 O que quer dizer com "não funcionou"? Acontece algum erro na sua macro? Em que parte? Dê mais detalhes e se possível anexe os arquivos.

Olá @Midori, desculpa a demora em responder,

O erro que esta dando é erro de compilação,

adicionei a imagem e os arquivos pra você olhar.

DBace.zip

Midori · 12 de setembro de 2022

@Sergio31 Para testar coloque o banco de dados no mesmo diretório ou altere a atribuição,

Sub ConectaDb()
    Dim Cnn         As New ADODB.Connection
    Dim Rs          As New ADODB.Recordset
    Dim PlanRTD     As Worksheet
    Dim BancoDados  As String
    Dim SQL         As String

    Set PlanRTD = ThisWorkbook.Sheets("RTD9")
    
    BancoDados = ThisWorkbook.Path & "\DBace.accdb"
    Cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & BancoDados & ";" & _
        "Jet OLEDB:Database Password=MyDbPassword;"
    
    Cnn.Open
    
    SQL = "Select * from bd_rtd"
    Rs.Open SQL, Cnn, adOpenKeyset, adLockOptimistic
    
    Do
        Rs.AddNew
        Rs.Fields("num") = PlanRTD.Range("D9")
        Rs.Fields("hora") = PlanRTD.Range("D10")
        Rs.Fields("preco") = PlanRTD.Range("D11")
        Rs.Fields("qtd") = PlanRTD.Range("D12")
        Rs.Update
    Loop Until PlanRTD.Range("D9") <> PlanRTD.Range("E9")
    
    Cnn.Close

End Sub

Sergio31 · 12 de setembro de 2022

3 horas atrás, Midori disse:

@Sergio31 Para testar coloque o banco de dados no mesmo diretório ou altere a atribuição,

Sub ConectaDb()
    Dim Cnn         As New ADODB.Connection
    Dim Rs          As New ADODB.Recordset
    Dim PlanRTD     As Worksheet
    Dim BancoDados  As String
    Dim SQL         As String

    Set PlanRTD = ThisWorkbook.Sheets("RTD9")
    
    BancoDados = ThisWorkbook.Path & "\DBace.accdb"
    Cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & BancoDados & ";" & _
        "Jet OLEDB:Database Password=MyDbPassword;"
    
    Cnn.Open
    
    SQL = "Select * from bd_rtd"
    Rs.Open SQL, Cnn, adOpenKeyset, adLockOptimistic
    
    Do
        Rs.AddNew
        Rs.Fields("num") = PlanRTD.Range("D9")
        Rs.Fields("hora") = PlanRTD.Range("D10")
        Rs.Fields("preco") = PlanRTD.Range("D11")
        Rs.Fields("qtd") = PlanRTD.Range("D12")
        Rs.Update
    Loop Until PlanRTD.Range("D9") <> PlanRTD.Range("E9")
    
    Cnn.Close

End Sub

@Midori Não esta dando nenhuma mensagem de erro mas não esta enviando para o BD,
o arquivo Connect_db.xlsm esta na mesma pasta do DBace.accdb., A parte de duplicar e copiar coluna esta funcionado. tentei alterar a coluna do Loop de "D9<>E9 para E9<>F9" mas continua sem enviar dados
para tabela.

DBace.zip

Midori · 12 de setembro de 2022

@Sergio31 Como tentou enviar os dados para o banco de dados? Executou a macro com F5? Não está salvando em outro banco de dados? Fiz um teste aqui e atualizou normalmente. Deixe os dois arquivos no mesmo diretório e a atribuição como postei,

BancoDados = ThisWorkbook.Path & "\DBace.accdb"

Sergio31 · 12 de setembro de 2022

14 minutos atrás, Midori disse:
@Sergio31 Como tentou enviar os dados para o banco de dados? Executou a macro com F5? Não está salvando em outro banco de dados? Fiz um teste aqui e atualizou normalmente. Deixe os dois arquivos no mesmo diretório e a atribuição como postei,
BancoDados = ThisWorkbook.Path & "\DBace.accdb"

@Midori, Esta enviando os dados , só que esta travando em loop e enviando somente uma linha repetida varias vezes. no anexo na coluna "num" da pra ver a linha se repetindo.

Midori · 12 de setembro de 2022

@Sergio31 Aí já é questão de você explicar porque colocou esse loop e qual é o critério para enviar os valores para o banco e dados.

Sergio31 · 12 de setembro de 2022

5 minutos atrás, Midori disse:

@Sergio31 Aí já é questão de você explicar porque colocou esse loop e quando quer enviar os valores para o banco e dados.

@Midori Eu tentei enviar de forma automática a cada vez que a coluna se atualiza-se. Achei que esse loop diferenciando as colunas atualizadas conseguiria fazer o envio de forma automática.

Conect_bd.zip

Midori · 12 de setembro de 2022

@Sergio31 Com comentou no primeiro post, sua planilha tem um link RTD. Então acho melhor usar o evento Calculate em vez desse loop já que a cada atualização do link o Calculate será ativado.

Private Sub Worksheet_Calculate()
    Application.EnableEvents = False
    Call ConectaDb
    Application.EnableEvents = True
End Sub

Sub ConectaDb()
    Dim Cnn         As New ADODB.Connection
    Dim Rs          As New ADODB.Recordset
    Dim PlanRTD     As Worksheet
    Dim BancoDados  As String
    Dim SQL         As String

    Set PlanRTD = ThisWorkbook.Sheets("RTD9")
    
    BancoDados = ThisWorkbook.Path & "\DBace.accdb"
    Cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & BancoDados & ";" & _
        "Jet OLEDB:Database Password=MyDbPassword;"
    
    Cnn.Open
    
    SQL = "Select * from bd_rtd"
    Rs.Open SQL, Cnn, adOpenKeyset, adLockOptimistic
    
    Rs.AddNew
    Rs.Fields("num") = PlanRTD.Range("D9")
    Rs.Fields("hora") = PlanRTD.Range("D10")
    Rs.Fields("preco") = PlanRTD.Range("D11")
    Rs.Fields("qtd") = PlanRTD.Range("D12")
    Rs.Update
    
    Cnn.Close

End Sub

Sergio31 · 12 de setembro de 2022

1 hora atrás, Midori disse:

@Sergio31 Com comentou no primeiro post, sua planilha tem um link RTD. Então acho melhor usar o evento Calculate em vez desse loop já que a cada atualização do link o Calculate será ativado.

Private Sub Worksheet_Calculate()
    Application.EnableEvents = False
    Call ConectaDb
    Application.EnableEvents = True
End Sub

Sub ConectaDb()
    Dim Cnn         As New ADODB.Connection
    Dim Rs          As New ADODB.Recordset
    Dim PlanRTD     As Worksheet
    Dim BancoDados  As String
    Dim SQL         As String

    Set PlanRTD = ThisWorkbook.Sheets("RTD9")
    
    BancoDados = ThisWorkbook.Path & "\DBace.accdb"
    Cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & BancoDados & ";" & _
        "Jet OLEDB:Database Password=MyDbPassword;"
    
    Cnn.Open
    
    SQL = "Select * from bd_rtd"
    Rs.Open SQL, Cnn, adOpenKeyset, adLockOptimistic
    
    Rs.AddNew
    Rs.Fields("num") = PlanRTD.Range("D9")
    Rs.Fields("hora") = PlanRTD.Range("D10")
    Rs.Fields("preco") = PlanRTD.Range("D11")
    Rs.Fields("qtd") = PlanRTD.Range("D12")
    Rs.Update
    
    Cnn.Close

End Sub

@Midori Esta Perfeito, Gratidão pela sua ajuda. Esta enviando todos os dados.