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

 

[BrianB]

I think the best method would be to "Find" your record in Access and add the new data if that fails. Here is some code that hopefully helps

'=============================================================================
'- UPDATE AN ACCESS RECORD FROM EXCEL
'- FIND SPECIFIED RECORD IN AN ACCESS TABLE FROM EXCEL
'=============================================================================
'- EXCEL  : GETS LOOKUP VALUE FROM ROW CONTAINING SELECTED CELL COLUMN A
'- ACCESS : CHECKS CORRECT RECORD FOUND
'- ACCESS : REPLACES RECORD VALUES WITH EXCEL WORKSHEET VALUES
'- We save code by "changing" field values even if they are the same.
'- Brian Baulsom November 2008
'=============================================================================
Dim ws As Worksheet
Dim FromRow As Long
Dim FromCol As Integer
Dim MyColumnCount As Integer
Dim MyPath As String
Dim db As Database
Dim MyTable As Recordset
Dim MyLookupValue As String
Dim MyMsg As String
Dim MsgLine1 As String
Dim rsp
'=============================================================================
'- MAIN ROUTINE
'=============================================================================
Sub UPDATE_RECORD()
    '-------------------------------------------------------------------------
    '- ASSUMES ACCESS .MDB IS IN THE SAME FOLDER AS THIS WORKBOOK
    MyPath = ThisWorkbook.Path & "\"
    ChDrive MyPath
    ChDir MyPath
    '-------------------------------------------------------------------------
    '- EXCEL : GET LOOKUP VALUE & NUMBER OF COLUMNS
    Set ws = ActiveSheet
    With ws
        FromRow = ActiveCell.Row
        MyColumnCount = .Cells(FromRow, .Columns.Count).End(xlToLeft).Column
        MyLookupValue = .Cells(FromRow, "A").Value
    End With
    '-------------------------------------------------------------------------
    '- ACCESS : SET RECORDSET = TABLE
    Set db = DBEngine(0).OpenDatabase(MyPath & "test.mdb")
    Set MyTable = db.OpenRecordset("TestTable1", dbOpenDynaset)
    With MyTable
        '---------------------------------------------------------------------
        '- DO LOOKUP. HERE USES FIELD CALLED "Field1"
        .FindFirst "Field1='" & MyLookupValue & "'"
        '---------------------------------------------------------------------
        '- CHECK IF MATCH FOUND
        If .NoMatch Then
            MsgBox (MyLookupValue & " not found.")
            GoTo GetOut
        Else
            '------------------------------------------------------------------
            '- MESSAGE TO CHECK CURRENT RECORD
            MsgLine1 = "FOUND RECORD CONTENTS BELOW.     OK to change ?"
            GetMessage          ' SUBROUTINE
           rsp = MsgBox(MyMsg, vbOKCancel, "  FOUND RECORD")
           If rsp = vbCancel Then GoTo GetOut
            '------------------------------------------------------------------
            '- UPDATE ACCESS RECORD
            .Edit
            For FromCol = 1 To MyColumnCount
                .Fields(FromCol - 1).Value = ws.Cells(FromRow, FromCol).Value
            Next
            .Update
            '------------------------------------------------------------------
        End If
    End With
    '--------------------------------------------------------------------------
    '- CONFIRMATION MESSAGE
    MsgLine1 = "CONFIRM CHANGE"
    GetMessage          ' SUBROUTINE
    rsp = MsgBox(MyMsg, vbOKOnly, " CURRENT POSITION")
    '--------------------------------------------------------------------------
GetOut:
    MyTable.Close
    db.Close
    Set MyTable = Nothing
    Set db = Nothing
End Sub
'=============================================================================
'- SUBROUTINE TO SET UP MESSAGE
'- aligns XL values using spaces (not an exact science)
'=============================================================================
Private Sub GetMessage()
    Dim XLval As Variant
    Dim ACval As Variant
    Dim XLalignment As Integer  ' MESSAGE ALIGN XL COLUMN WITH SPACES
    XLalignment = 30
    '-------------------------------------------------------------------------
    With MyTable
        MyMsg = MsgLine1 & vbCr & vbCr _
        & "ACCESSS" & Space(XLalignment) & "EXCEL" & vbCr & vbCr
        '---------------------------------------------------------------------
        '-  CHECK COLUMNS
        For FromCol = 1 To MyColumnCount
            XLval = ws.Cells(FromRow, FromCol)
            ACval = .Fields(FromCol - 1).Value
            MyMsg = MyMsg _
                & .Fields(FromCol - 1).Name & " : " & ACval _
                & Space(XLalignment - Len(CStr(ACval))) _
                & IIf(XLval = ACval, "      =  ", "---->> *") & XLval & vbCr
        Next
    End With
End Sub
'-----------------------------------------------------------------------------

 

[mxtreme]

Brian - many thanks for your help
Great Excel help
thanks again