Código: Selecionar todos
Sub ConectaDB()
Dim cnn As New ADODB.Connection
Dim bncDados As String
Dim wbk As Workbook
Dim Sql As String
Dim rs As New Recordset
Dim lin As Long
Dim ultLin As Long
Dim Cod As String
Set wbk = WbDataBase
lin = 2
ultLin = Application.WorksheetFunction.CountA(Planilha2.Range("A:A"))
bncDados = wbk.Path & "\DB.accdb"
If cnn.State = 0 Then
cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & bncDados & ";" & _
"Jet OLEDB:Database Password="
cnn.Open
End If
With Planilha2
For lin = 2 To ultLin
Cod = .Cells(lin, 2)
Turma = .Cells(1, 1)
Sql = "Select * From Produtos Where RM Like '" & Cod & "' And Classe like '" & Turma & "'"
rs.Open Sql, cnn, adOpenKeyset, adLockOptimistic
If rs.RecordCount > 0 Then
rs!Nome = .Cells(lin, 1)
rs!RM = .Cells(lin, 2)
rs!Classe = .Cells(1, 1)
rs!Disc1 = .Cells(lin, 8)
rs!Disc2 = .Cells(lin, 9)
rs!Disc3 = .Cells(lin, 10)
rs!Disc4 = .Cells(lin, 11)
rs!Disc5 = .Cells(lin, 12)
rs!Disc6 = .Cells(lin, 13)
rs.Update
Else
rs.AddNew
rs!Nome = .Cells(lin, 1)
rs!RM = .Cells(lin, 2)
rs!Classe = .Cells(1, 1)
rs!Disc1 = .Cells(lin, 8)
rs!Disc2 = .Cells(lin, 9)
rs!Disc3 = .Cells(lin, 10)
rs!Disc4 = .Cells(lin, 11)
rs!Disc5 = .Cells(lin, 12)
rs!Disc6 = .Cells(lin, 13)
rs.Update
End If
rs.Close
Next lin
End With
cnn.Close
End Sub
Desde já agradeço