VBA Code to ensure data just sent to Access from Excel are not duplicates

[mxtreme]

Hi folks - I am in need of help please
I am trying to de-duplicate data coming from Excel to Access
The part I am having problems with is
(I have attached the full code at the bottom too to help)
Any help would be greatly appreciated and needed

Set DBz = _
    OpenDatabase("C:\Documents and Settings\_XXXXX_\My Documents\S_B\7-16-A_D_B.mdb")
Set rsz = DBz.OpenRecordset("Data_Weekly", dbOpenTable)
 
 
With ThisWorkbook.Worksheets("Data_Weekly")
     ExcelRecord = Advocatecomp & MDate
End With
 
AccessRecord = rsz.Fields("Value") & rsz.Fields("Date")
 
If ExcelRecord = AccessRecord Then
   bFound = True
   Call MsgBox("Advocate Work Completed on time Metrics already exist in the ADB" _
               & vbCrLf & "Please click ok to cancel this import" _
               , vbCritical, "LLF- Ca")
 
               Exit Sub
 
Else
  bFound = False
     Call MsgBox("Advocate Work Completed on time Metrics Do Not Already exist in the ADB" _
               & vbCrLf & "Please click ok to import this metric" _
               , vbCritical, "LLF- Ca")
End If

Public Sub SaveWPPercent()
Dim MDate As Date
Dim Rptpath As String
Dim RptName As String
Dim DateCheck As Date
Dim Advocatecomp As Single
Dim X As Single
 
Dim MSQL As String
Dim DBS As DAO.Database
Dim RST As DAO.Recordset
Dim DBSName As String
Dim dBSPath As String
Dim Mmetric_ID As Single
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim bFound As Boolean 'new 7-15
Dim ExcelRecord As String 'new 7-15
Dim AccessRecord As String 'new 7-15
Dim DBz As Database, rsz As DAO.Recordset, r As Long 'new  7-15
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'open the report
'check to make sure the date matches
'find the metric ID in the ADB
'save the value to the weekly data table
'if the value is already there, then replace it
 
'make sure there is a date in the date box----------------------------------------------------------------------------------------
If Not IsDate(Me.cboWE.Value) Then
    MsgBox "Please select a week ending date!", vbCritical, "Error"
    Exit Sub
Else
    MDate = Me.cboWE.Value
End If
 
'make sure report there is a report chosen----------------------------------------------------------------------------------------
If Me.txtWorkPackage = "" Then
    MsgBox "Please enter a valid report path for Advocate Completed on Time!", vbCritical, "Error"
    Exit Sub
Else
    Rptpath = Me.txtWorkPackage
End If
 
'check to see if the dates match--------------------------------------------------------------------------------------------------
Workbooks.Open Rptpath, False, True
RptName = ActiveWorkbook.Name
DateCheck = Workbooks(RptName).Worksheets("Input Sheet").Cells(2, 1)
If DateCheck <> MDate Then
    If MsgBox("The date in the workbook: " & RptName & " do not match! Do you wish to continue?", vbYesNo, "Error! Dates do not match!") = vbYes Then
        MsgBox "The value will be assigned to the weekending date of " & MDate & "!"
    Else
        Exit Sub
    End If
 
End If
 
'find the Advocate completed on time metric for Italy--------------------------------------------------------------------------------
For X = 1 To 25
    If Workbooks(RptName).Worksheets("Input Sheet").Cells(X, 3).Value = "Italy total (calc=1)" Then
        'we have found the row
        Advocatecomp = Workbooks(RptName).Worksheets("Input Sheet").Cells(X, 5).Value
        Workbooks(RptName).Close False
        Exit For
    End If
 
Next X
 
'If there is no data then --------------------------------------------------------------------------------------------------------
If Advocatecomp = 0 Then
    MsgBox "Unable to locate the Italy Advocate completed on time value!", vbCritical, "Error!"
    Exit Sub
End If
 
'SQL to set data -----------------------------------------------------------------------------------------------------------------
 MSQL = " SELECT Metrics.Metric, Reporting_Hierarchy.Level_1, Metrics_X_Reporting_Hierarchy.Metric_ID, Data_Weekly.Date, " _
 & "Data_Weekly.Value " _
 & "FROM ((Metrics_X_Reporting_Hierarchy INNER JOIN Metrics ON Metrics_X_Reporting_Hierarchy.Metric_Name_ID = Metrics.Metric_Name_ID) " _
 & "INNER JOIN Reporting_Hierarchy ON Metrics_X_Reporting_Hierarchy.Hierarchy_ID = Reporting_Hierarchy.Hierarchy_ID) " _
 & "INNER JOIN Data_Weekly ON Metrics_X_Reporting_Hierarchy.Metric_ID = Data_weekly.Metric_ID " _
 & "WHERE (((Metrics.Metric)='" & "Advocate Completed On Time - Weekly" & "') " _
 & "AND ((Reporting_Hierarchy.Level_1)='" & "Italy" & "') " _
 & "AND ((Data_weekly.Date)='" & MDate & "'));"
 
'set the variable-----------------------------------------------------------------------------------------------------------------
bFound = False 'added 7-16
 
'where is the path and name of the access file -----------------------------------------------------------------------------------
dBSPath = "C:\Documents and Settings\ra94\My Documents\Scorecard_Button"
DBSName = "7-16-MOS_Data_Repository.mdb"
 
'set DBS--------------------------------------------------------------------------------------------------------------------------
Set DBS = OpenDatabase(dBSPath & "\" & DBSName)
 
'set record set-------------------------------------------------------------------------------------------------------------------
Set RST = DBS.OpenRecordset(MSQL)
If Not RST.EOF Then
    'record exists, find the record in the data_montly table and edit the value of the existing record
    'add to restatement and notify the user
 
        Mmetric_ID = RST!metric_ID
        Set RST = Nothing 'want to reuse the variable - need to clear it out.
        MSQL = "SELECT Data_weekly.Metric_ID, Data_weekly.Date, Data_weekly.Value " _
        & "FROM Data_weekly " _
        & "WHERE (((Data_weekly.Metric_ID)= " & Mmetric_ID & ") " _
        & "AND ((Data_weekly.Date)='" & MDate & "'));"
        Set RST = DBS.OpenRecordset(MSQL)
        RST.MoveFirst
        RST.Edit
        RST!Value = Advocatecomp
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set DBz = _
    OpenDatabase("C:\Documents and Settings\_XXXXX_\My Documents\S_B\7-16-A_D_B.mdb")
Set rsz = DBz.OpenRecordset("Data_Weekly", dbOpenTable)
 
 
With ThisWorkbook.Worksheets("Data_Weekly")
     ExcelRecord = Advocatecomp & MDate
End With
 
AccessRecord = rsz.Fields("Value") & rsz.Fields("Date")
 
If ExcelRecord = AccessRecord Then
   bFound = True
   Call MsgBox("Advocate Work Completed on time Metrics already exist in the ADB" _
               & vbCrLf & "Please click ok to cancel this import" _
               , vbCritical, "LLF- Ca")
 
               Exit Sub
 
Else
  bFound = False
     Call MsgBox("Advocate Work Completed on time Metrics Do Not Already exist in the ADB" _
               & vbCrLf & "Please click ok to import this metric" _
               , vbCritical, "LLF- Ca")
End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        RST.Update
        Set RST = Nothing
 
 
Else
    'record doesn't exist.  Find the metric_ID in the CR table - if the metric id is found, insert the record into the data_monthly table
 
     MSQL = "SELECT Reporting_Hierarchy.Level_1, Metrics.Metric, Metrics_X_Reporting_Hierarchy.Metric_ID " _
     & "FROM (Reporting_Hierarchy INNER JOIN Metrics_X_Reporting_Hierarchy ON Reporting_Hierarchy.Hierarchy_ID = Metrics_X_Reporting_Hierarchy.Hierarchy_ID) " _
     & "INNER JOIN Metrics ON Metrics_X_Reporting_Hierarchy.Metric_Name_ID = Metrics.Metric_Name_ID " _
     & "WHERE (((Reporting_Hierarchy.Level_1)= '" & "Italy" & "') " _
     & "AND ((Metrics.Metric)= '" & "Advocate Completed On Time - Weekly" & "'));"
 
 
      Set RST = DBS.OpenRecordset(MSQL)
      RST.MoveFirst
      Mmetric_ID = RST!metric_ID
      Set RST = Nothing
      MSQL = "Select * from Data_Weekly"
      Set RST = DBS.OpenRecordset(MSQL)
      RST.AddNew
      RST!Date = MDate
      RST!metric_ID = Mmetric_ID
      RST!Value = Advocatecomp
      RST!Status = "Active"
      RST.Update
      Set RST = Nothing
    MsgBox "Metrics have been imported!", vbOKOnly, "Import Completed!" 'moved from import click to here
End If
 
 
End Sub
 

[nico5038]

Just curious why the user has to click for ignoring duplicates.

I would have excluded them entirely from the data set to be inspected, or ignored them and issued an INSERT that will skip dupes for the specified unique key field(s).

What's the way you intend this code to work?

Nic;o)

[mxtreme]

Hi Nico thanks for getting to my thread I could really use your help. All I need is to make sure the data being imported via a command button if pressed more then once that the data does not duplicate as many as extra times the button was pressed. So lets say you press that button to import metrics into access. But another co-worker did not check access to see if the data is there, and they press the button to import the data again. I need to block this from happening. Please advise

[nico5038]

As indicated, when inserting a new record, Access will "block" duplicates when you have defined the unique ID.

I see your add code:
RST!Date = MDate
RST!metric_ID = Mmetric_ID
RST!Value = Advocatecomp
RST!Status = "Active"
and I assume MDate, Mmetric_ID and Advocatecomp make up the unique record. Thus defining a unique index on the table consisting from these fields with the option "No duplicates allowed" will make sure no duplicate records can be added.

I normally issue a "Docmd.exec ute ("<Insert statement>")" to add rows and this will suppress error messages when adding a duplicate row, as it won't add the data.

Still would need some information on the "Status" field. When there's a row with Status <> "Active", will this trigger the Status field to change ?

Nic;o)

[mxtreme]

Nico again thank you so much. You are a bit over my head - could you simplify things or please give the code to exit sub if found?

[nico5038]

The whole point is that I don't check for duplicates, I just add all rows and Access will "drop" the duplicates because of the defined unique key in the table.

Normally I import an excel sheet into a temp table and show that to the user in a form. Here I add an indication showing duplicates yes or no. (using an outer (left or right) join with the production table.)
Thus the user can see which rows will be added and check for typo's causing erroneous duplicates. After correcting this the final import can be executed "straight away" with an "append" query, no code needed.

What is the reason to show the rows first to the user, instead of importing it directly?

Nic;o)

[mxtreme]

Nico - I think I am getting it now.
Can you show me a code where this will take my data and do your method with a form? I know I am asking a lot but I would really appreciate it

[nico5038]

Just attach (part of) the .mdb and a sample excelsheet to your post (Use "Go Advanced" button) so I can show you.
(I'm lazy, I know :-)

Nic;o)

[mxtreme]

great will do when I get the file after the weekend.
May I ask why is this not working?

Private Sub CommandButton1_Click()
On Error GoTo errline
 
 
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
    ' connect to the Access database
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
        "Data Source=C:\Documents and Settings\Ben\My Documents\Excel VBA\7-18.mdb;"
    ' open a recordset
    Set rs = New ADODB.Recordset
    rs.Open "Table1", cn, adOpenKeyset, adLockOptimistic, adCmdTable
    ' all records in a table
    r = 2 ' the start row in the worksheet
    Do While Len(Range("A" & r).Formula) > 0
    ' repeat until first empty cell in column A
        With rs
            .AddNew ' create a new record
            ' add values to each field in the record
            .Fields("date") = Range("A" & r).Value
            .Fields("item") = Range("B" & r).Value
            .Fields("number") = Range("C" & r).Value
            ' add more fields if necessary...
            .Update ' stores the new record
 
 
        End With
        r = r + 1 ' next row
    Loop
exitline:
Exit Sub
 
errline:
 Select Case Error.Number
 Case 2147217887
 MsgBox "This would cause duplicates in the MDR click OK to cancel"
 Cancel = True
 
 Case Else
 MsgBox "There was an error in the program please contact MOS Administrator"
  GoTo exitline
  End Select
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
 
 
End Sub

[nico5038]

Hmm, the Range looks a bit odd, as it's an excel method and I would have expected automation instead of recordset processing. Once a sheet has been opened as a recordset, the origin (text, excel, access, etc.) doesn't bother.

In general I just use linked excel sheets to get all handling similar.

Nic;o)