Boa noite! Estou com um problema no meu código VBA e não consigo descobrir aonde, vocês poderiam me ajudar?! Fiz um código VBA para atualizar e/ou inserir a quantidade de estoque, ele funciona até bem, mas quando se coloca compras grandes alguns registros anteriores são zerados. Não consegui descobrir o porque...
*** Tbm tenho a tabela de venda mas ainda nem comecei a testar porque a de compra está dando este problema.
Abaixo vão as os campos das tabelas (colocarei só os campos em questão pra ser mais suscinta), algumas sobre o programinha que estou desenvolvendo e as versões de software. Não vou postar agora o arquivo porque minha net está muito ruim por causa da chuva (pelo menos acho que é isso), mas se precisar arranjo um jeito.
Office 2013; Windows 8.1 64b
TblProduto
ID
CodBarras
CodEmpresa
NmProduto
TblDetProduto
ID
IDProduto
IDTamanho
IDCor
QtdEstoque
QtdMin
TblCompra
ID
NtFiscal
IDEmpresa
TblDetCompra
ID
IDCompra
CodEmpresa
IDProduto
IDTamanho
IDCor
Qtd
Código VBA de Estoque:
Sub AtualizaProdutoEntrada()
Dim strSQL As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim cn As String
Dim Criteria As Integer
Dim cs
cs = DMax("ID", "TblCompra")
cn = "SELECT IDProduto, IDTamanho, IDCor, Qtd FROM TblDetCompra WHERE IDCompra=" & cs
Set db = CurrentDb
Set rs = db.OpenRecordset(cn, dbOpenDynaset)
Do Until rs.EOF
Criteria = Nz(DCount("ID", "TblDetProduto", "IDProduto=" & rs("IDProduto") & " AND IDTamanho=" & rs("IDTamanho") & " AND IDCor=" & _
rs("IDCor")), 0)
If Criteria = 0 Then
strSQL = "INSERT INTO TblDetProduto ( IDProduto, IDTamanho, IDCor, QtdEstoque )" & _
"VALUES(" & _
rs("IDProduto") & ",'" & _
rs("IDTamanho") & "','" & _
rs("IDCor") & "','" & _
rs("Qtd") & "')"
db.Execute strSQL
Else
strSQL = "UPDATE TblDetProduto SET TblDetProduto.QtdEstoque =" & _
"[TblDetProduto].[QtdEstoque]+" & rs("Qtd") & " WHERE IDProduto=" & rs("IDProduto") & " AND IDTamanho=" & _
rs("IDTamanho") & " AND IDCor=" & _
rs("IDCor") & ";"
db.Execute strSQL
End If
rs.MoveNext
Loop
AtualizaProdutoEntrada_Exit:
On Error Resume Next
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
Exit Sub
AtualizaProdutoEntrada_Err:
MsgBox err.Description, vbCritical, "ERRO!"
Resume AtualizaProdutoEntrada_Exit
End Sub
Agradeço desde já!
Camila Santos
*** Tbm tenho a tabela de venda mas ainda nem comecei a testar porque a de compra está dando este problema.
Abaixo vão as os campos das tabelas (colocarei só os campos em questão pra ser mais suscinta), algumas sobre o programinha que estou desenvolvendo e as versões de software. Não vou postar agora o arquivo porque minha net está muito ruim por causa da chuva (pelo menos acho que é isso), mas se precisar arranjo um jeito.
Office 2013; Windows 8.1 64b
TblProduto
ID
CodBarras
CodEmpresa
NmProduto
TblDetProduto
ID
IDProduto
IDTamanho
IDCor
QtdEstoque
QtdMin
TblCompra
ID
NtFiscal
IDEmpresa
TblDetCompra
ID
IDCompra
CodEmpresa
IDProduto
IDTamanho
IDCor
Qtd
Código VBA de Estoque:
Sub AtualizaProdutoEntrada()
Dim strSQL As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim cn As String
Dim Criteria As Integer
Dim cs
cs = DMax("ID", "TblCompra")
cn = "SELECT IDProduto, IDTamanho, IDCor, Qtd FROM TblDetCompra WHERE IDCompra=" & cs
Set db = CurrentDb
Set rs = db.OpenRecordset(cn, dbOpenDynaset)
Do Until rs.EOF
Criteria = Nz(DCount("ID", "TblDetProduto", "IDProduto=" & rs("IDProduto") & " AND IDTamanho=" & rs("IDTamanho") & " AND IDCor=" & _
rs("IDCor")), 0)
If Criteria = 0 Then
strSQL = "INSERT INTO TblDetProduto ( IDProduto, IDTamanho, IDCor, QtdEstoque )" & _
"VALUES(" & _
rs("IDProduto") & ",'" & _
rs("IDTamanho") & "','" & _
rs("IDCor") & "','" & _
rs("Qtd") & "')"
db.Execute strSQL
Else
strSQL = "UPDATE TblDetProduto SET TblDetProduto.QtdEstoque =" & _
"[TblDetProduto].[QtdEstoque]+" & rs("Qtd") & " WHERE IDProduto=" & rs("IDProduto") & " AND IDTamanho=" & _
rs("IDTamanho") & " AND IDCor=" & _
rs("IDCor") & ";"
db.Execute strSQL
End If
rs.MoveNext
Loop
AtualizaProdutoEntrada_Exit:
On Error Resume Next
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
Exit Sub
AtualizaProdutoEntrada_Err:
MsgBox err.Description, vbCritical, "ERRO!"
Resume AtualizaProdutoEntrada_Exit
End Sub
Agradeço desde já!
Camila Santos