1

我创建了一个 Access 数据库，我想将它分发给一个小组。虽然我总是可以在 excel 中导出表格并在那里合并/追加数据，但有没有办法同步数据库，也许是使用 VBA？

进一步说明，在数据库应用程序中的一种形式中，可能存在同步按钮，并且单击时，可能会打开一个对话框以查找要与之同步的accdb。随之而来的是 VBA 将在两个 accdbs 之间“同步”有问题的表（当然具有相同的结构）。

这可能吗？洞察力会很好。谢谢！

4

2 回答 2

4

是的，这是完全可能的。以下是有关比较两个数据库和记录更改的一些说明。

该过程需要模块顶部的以下内容：

Dim strFileNew As String 
Dim strFileOld As String 
Dim strLog As String
Dim dbOld As Database

变量可能包含： 

strLog = "log.txt"
strFileNew = "z:\docs\dbNew.mdb"
strFileOld = "z:\docs\dbOld.mdb"
Set dbOld = OpenDatabase(strFileOld)

然后对比：

Sub LogCompareDB(db As Database)
''References : Windows Script Host Object Model
''           This is set by default for a number of versions
''           : Microsoft DAO x.x Object Library
''           For 2010, the DAO library is called 
''           :Microsoft Office 12.0 Access Database Engine Object Library

Dim tdf As TableDef
Dim rs0 As DAO.Recordset
Dim rs1 As DAO.Recordset
Dim fld As DAO.Field
Dim idx As Index
Dim idxPrimary  As Index
Dim strIndexList As String
Dim strIndex As String
Dim strID As String
Dim strSQL As String
Dim strChanged As String
Dim blnNew As Boolean
Dim fs As New FileSystemObject
Dim ts As TextStream

    Set ts = fs.CreateTextFile(strLog, True)

    ''For each table in the old database
    ''(It would probably be a good idea to check the
    ''new database for added tables)
    For Each tdf In db.TableDefs
        '' Skip system tables
        If Left(tdf.Name, 4) <> "MSys" Then
            strIndex = vbNullString
            Set idxPrimary = Nothing
            strIndexList = vbNullString

            ''Get the primary index and index fields
            For Each idx In tdf.Indexes
                If idx.Primary = True Then
                    Set idxPrimary = idx
                    For Each fld In idx.Fields
                        strIndex = strIndex & " AND t0.[" & fld.Name _
                            & "] = t1.[" & fld.Name & "]"
                        strIndexList = strIndexList & "," & fld.Name
                    Next
                    strIndex = Mid(strIndex, 5)
                End If
            Next

            ''There is no basis for comparison if there is no index.
            ''A unique index would also be a possibility, but hey, let's
            ''not go over the top :)
            If strIndex > vbNullString Then

                ''Select all records from the table for both databases
                strSQL = "SELECT * FROM [;DATABASE=" & strFileNew & "].[" _
                    & tdf.Name & "] As t0 LEFT JOIN [" _
                    & tdf.Name & "] As t1 ON " & strIndex

                Set rs0 = db.OpenRecordset(strSQL)

                ''A convenient list of fields from the old database
                ''It would probably be a good idea to check the
                ''new database for added fields.

                strSQL = "SELECT * FROM [;DATABASE=" & strFileOld & "].[" _
                    & tdf.Name & "] As t0 WHERE 1=2"

                Set rs1 = db.OpenRecordset(strSQL)

                Do While Not rs0.EOF
                    strID = vbNullString
                    blnNew = False

                    ''If the index fields are null, then it is a new record
                    For Each fld In idxPrimary.Fields
                        strID = strID & fld.Name & ": " & rs0("[t0." & fld.Name & "]") & vbCrLf

                        If IsNull(rs0("[t1." & fld.Name & "]")) Then
                            blnNew = True
                        End If
                    Next

                    If blnNew Then
                        ''Write to log
                        ts.WriteLine "NEW RECORD " & strID & vbCrLf
                    Else
                        ''Not a new record, so is it a changed record?
                        strChanged = vbNullString

                        For Each fld In rs1.Fields
                            ''No need to check index fields, because they are equal
                            If InStr(strIndexList, fld.Name) = 0 Then

                                ''Add null string for purposes of comparison                                 ''trailing
                                If "" & rs0("[t0." & fld.Name & "]") <> "" & rs0("[t1." & fld.Name & "]") Then
                                    strChanged = strChanged & vbCrLf _
                                        & fld.Name & "  Is: " & Trim(rs0("[t0." & fld.Name & "]")) _
                                        & "  Was: " & Trim(rs0("[t1." & fld.Name & "]"))
                                End If
                            End If
                        Next

                        If strChanged <> vbNullString Then
                            ''Write to log
                            ts.WriteLine "CHANGED RECORD " & strID
                            ts.WriteLine strChanged & vbCrLf
                        End If
                    End If

                    rs0.MoveNext
                Loop
            Else
                ts.WriteLine "NO PRIMARY INDEX " & tdf.Name & vbCrLf
            End If
        End If
    Next

   ts.Close
   FollowHyperlink strLog
End Sub
于 2012-07-31T09:46:48.937 回答
0 
Option Compare Database

Private Sub Command4_Click()

Dim tablename1, tablename2 As String
tablename1 = Text0.Value
tablename2 = Text2.Value

'On Error GoTo Err_cmdValidateGeneralInfo_Click
Dim F As DAO.Field
Dim rs As DAO.Recordset
Dim rs1 As DAO.Recordset
Set curDB = CurrentDb()
'If Me.DateModified = Date Then
    'Adds new employees to the TT_GeneralInfo table in the FTEI_PhoneBook.mdb -    which     is used thru out the AP databases.
 '   DoCmd.OpenQuery "qryEmpData_TT_General"

strsql = "Select * from " & tablename1

Set rs = curDB.OpenRecordset(strsql)

strsql1 = "Select * from " & tablename2

   DoCmd.CopyObject , "Unmatched_records", acTable, tablename1
   curDB.Execute "DELETE FROM Unmatched_records"

Set rs1 = curDB.OpenRecordset(strsql1)
    Do Until rs.EOF
      For Each F In rs.Fields
        If rs.Fields(F.Name) <> rs1.Fields(F.Name) Then
          'rs.Edit
          strsql = "Select * into test from " & tablename1 & " where " & F.Name & "   = """ & rs.Fields(F.Name) & """"
          DoCmd.RunSQL strsql

          If DCount(F.Name, "test") <> 0 Then
          GoTo append_unmatch

          'appending unmacthed records
append_unmatch:

          strsql2 = "insert into Unmatched_records Select * from test"
          DoCmd.RunSQL strsql2

          'if record doesnt match move to next one
          GoTo Nextrecord
          End If
         ' rs.Fields(F.Name) = rs1.Fields(F.Name)
         ' rs.Update
        End If
      Next F

Nextrecord:
rs.MoveNext
rs1.MoveNext
    Loop

    If DCount("test", F.Name) <> 0 Then
    MsgBox ("The two tables didnt match. Check table test for unmatching reocrds.")
    Else
    MsgBox ("Tables match!")
    End If


End Sub
于 2012-12-24T11:35:31.410 回答