10 Replies Latest reply on Feb 10, 2014 8:52 AM by Simon Turner

    Exporting Excel Data into MS Access

    Parminder Singh

      Apoologies Guys, Posting help other than Solidworks.

       

      Need little help to Export Data from MS Excel To MS Access Database.

      I've succesfully able to Export the data into the database.

      Only stuffup with the Duplicate Entry.

       

      Assume i've data which is already into Access Table and still if im exporting it,

      the code should give the count of duplicate entry found and paste the other non duplicate entries.

       

       

      Please find the Macro enable Excel Sheet and MS Access Database.

       

      Really glad if someone assist me on this.

        • Re: Exporting Excel Data into MS Access
          Simon Turner

          Sub ADOFromExcelToAccessdbo_PartInformation()

          ' 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, rs2 As ADODB.Recordset, r As Long

          Dim myBook As Workbook

          Dim fso As New Scripting.FileSystemObject

           

          Set myBook = Application.ActiveWorkbook

           

          With ActiveSheet

           

              ' connect to the Access database

              Set cn = New ADODB.Connection

             

              cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & _

                  "Data Source=" & fso.GetParentFolderName(myBook.FullName) & "\SQL.accdb;"

               'open a recordset

              Set rs = New ADODB.Recordset

              Set rs2 = New ADODB.Recordset

                      rs.Open "dbo_PartInformation", 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

                     

                          XX = Range("A" & r).Value

                          YY = Range("B" & r).Value

                          ZZ = Range("C" & r).Value

                          KK = Range("D" & r).Value

           

                          'If DCount("*","[NameOfYourTableToCheck]", "[IDField] = " & SomeID & " AND [OtherField] = " & SomeOtherFiled) > 0 Then

                          'If DCount("*", "[dbo_PartInformation]", "[ParentProductNbr] = " & XX & " AND [SubEM] = " & YY) > 0 Then

                         

                          rs2.Open "SELECT COUNT(*) AS Tot FROM dbo_PartInformation WHERE ParentProductNbr='" & XX & "' AND SubEM='" & YY & "'", cn

                          If rs2("Tot") > 0 Then

                              MsgBox "This record already exists", vbOKOnly + vbExclamation, "Duplicate Record"

                              rs2.Close

                          Else

                              rs2.Close

                             

                              ' repeat until first empty cell in column A

                              With rs

                                  .AddNew ' create a new record

                                  ' add values to each field in the record

                                  .Fields("ParentProductNbr") = XX

                                  .Fields("SubEM") = YY

                                  .Fields("ProductNbr") = ZZ

                                  .Fields("SubAssemblyInfo") = KK

                                 .Update ' stores the new record

                              End With

                          End If

                         

                          r = r + 1 ' next row

                      Loop

                      rs.Close

                      cn.Close

                                         

              'MsgBox "Database updated", vbOKOnly

              lastRow = (.Cells(.Rows.Count, "A").End(xlUp).Row - 1)

              MsgBox "You are about to Paste" & " " & lastRow & " " & "Record(s).", vbExclamation

             End With

            

          End Sub