Sub Синхронизатор()
ThisWorkbook.Save
    If FolderExists("\\keenetic_viva\DEZ-Disk") Then
                Application.ScreenUpdating = False
                Application.Calculation = xlCalculationManual
                Application.EnableEvents = False
                Application.DisplayStatusBar = False
                Application.DisplayAlerts = False
    Dim bazname As String
    Dim ws As Worksheet, k As Integer
    Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Форма_обновления")
    Dim wss As Worksheet
    Dim Cn As Object, s As String
    Dim i As Long, adr As String
    k = 1
        For Each wss In ThisWorkbook.Worksheets
            Application.Wait Now + TimeSerial(0, 0, k)
            s = IIf(wss.Name = "Согл_статус", "", "and t1.[л/с] = t2.[л/с]")
            bazname = wss.Name
                Set ws = ThisWorkbook.Sheets(bazname)
                i = ws.Cells(Rows.Count, 1).End(xlUp).Row
                If bazname <> "Адрес" And bazname <> "Долг_последний" And bazname <> "ЖДСправка" Then
                    If Len(Dir("\\keenetic_viva\DEZ-Disk\01Аналитика\1.2 база данных\1.2.10 Центральная база\" & bazname & ".accdb")) Then
                    
                        Call база(bazname)
                        Set con = CreateObject("ADODB.Connection")
                        Set rst = CreateObject("ADODB.Recordset")
                        con.Open ("Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & ThisWorkbook.FullName & "; Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1""")
                        If ws2.Cells(1, 1) = "л/с" Then
                                rst.Open "Select t1.* From " & _
                                "(SELECT * FROM [Форма_обновления$]) t1 " & _
                                "Left join (SELECT * FROM [" & bazname & "$]) t2 on t1.[Идентификатор] = t2.[Идентификатор] " & s & _
                                "Where t2.[Идентификатор] is null and t1.[л/с] is not null", con
                                ws.Cells(i + 1, 1).CopyFromRecordset rst
                            rst.Close
                                rst.Open "Select t1.* From " & _
                                "(SELECT * FROM [" & bazname & "$]) t1 " & _
                                "Left join (SELECT * FROM [Форма_обновления$]) t2 on t1.[Идентификатор] = t2.[Идентификатор] " & s & _
                                "Where t2.[Идентификатор] is null and t1.[л/с] is not null", con
                        Else
                                rst.Open "Select t1.* From " & _
                                "(SELECT * FROM [Форма_обновления$]) t1 " & _
                                "Left join (SELECT * FROM [" & bazname & "$]) t2 on t1.[Идентификатор] = t2.[Идентификатор] " & s & _
                                "Where t2.[Идентификатор] is null", con
                                ws.Cells(i + 1, 1).CopyFromRecordset rst
                            rst.Close
                                rst.Open "Select t1.* From " & _
                                "(SELECT * FROM [" & bazname & "$]) t1 " & _
                                "Left join (SELECT * FROM [Форма_обновления$]) t2 on t1.[Идентификатор] = t2.[Идентификатор] " & s & _
                                "Where t2.[Идентификатор] is null", con
                        
                        
                        End If
                        Range(ws2.Cells(2, 1), ws2.Cells(ws2.Cells(Rows.Count, 1).End(xlUp).Row, ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column)).Clear
                        ws2.Cells(2, 1).CopyFromRecordset rst
                        rst.Close
                        con.Close
                        Call InsertTotable(bazname)
                    End If
                Else
                    If bazname = "Долг_последний" Or bazname = "ЖДСправка" Then
                        Call база(bazname)
                        Set con = CreateObject("ADODB.Connection")
                        Set rst = CreateObject("ADODB.Recordset")
                        con.Open ("Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & ThisWorkbook.FullName & "; Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1""")
                            rst.Open "(SELECT * FROM [Форма_обновления$])", con
                            wss.Cells(2, 1).CopyFromRecordset rst
                        rst.Close
                        con.Close
                    Else
                        If bazname = "Адрес" Then
                            i = ws.Cells(Rows.Count, 1).End(xlUp).Row
                            wss.Rows("2:" & i).ClearContents
                            adr = "\\keenetic_viva\DEZ-Disk\01Аналитика\1.2 база данных\1.2.10 Центральная база\Адрес.xlsb"
                            Set con = CreateObject("ADODB.Connection")
                            Set rst = CreateObject("ADODB.Recordset")
                            con.Open ("Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & adr & "; Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1""")
                                rst.Open "(SELECT * FROM [Адрес$])", con
                                wss.Cells(2, 1).CopyFromRecordset rst
                            rst.Close
                            con.Close
                        End If
                    End If
                End If
        Next wss
                Application.ScreenUpdating = True
                Application.Calculation = xlCalculationAutomatic
                Application.EnableEvents = True
                Application.DisplayStatusBar = True
                Application.DisplayAlerts = True
                MsgBox "Синхронизация завершена"
    Else
        MsgBox "Не удалось установить соединение с диском"
    End If
End Sub
Sub база(bazname As String)
Dim con As ADODB.connection
Dim rst As ADODB.Recordset
Dim obst As Worksheet: Set obst = ThisWorkbook.Sheets("Форма_обновления")
Dim col As Integer, fulnam As String, Connect As String, Source As String
    fulnam = "\\keenetic_viva\DEZ-Disk\01Аналитика\1.2 база данных\1.2.10 Центральная база\" & bazname & ".accdb"
    Set con = New ADODB.connection
    obst.Cells.Clear
    con.Open connectionString:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & fulnam & ";"
    
        Set rst = New ADODB.Recordset
            rst.Open Source:="SELECT * FROM [" & bazname & "]", ActiveConnection:=con
            
            For col = 0 To rst.Fields.Count - 1
                obst.Range("A1").Offset(0, col).Value = rst.Fields(col).Name
            Next
            obst.Cells(2, 1).CopyFromRecordset rst
        Set rst = Nothing
    con.Close
    Set con = Nothing
End Sub

Sub asdf()
    If FolderExists("\\keenetic_viva\DEZ-Disk") Then
        x = 1
    Else
        x = 2
    End If
End Sub
Function FolderExists(ByRef path As String) As Boolean
   On Error Resume Next
   FolderExists = GetAttr(path)
End Function
Sub InsertTotable(bazname As String)
    Const adOpenStatic = 3
    Const adOpenKeyset = 1
    Const adLockOptimistic = 3
    Const adLockReadOnly = 1
    Dim sCon As String, sSql As String
    Dim Cn As Object, q As Object
    Dim Sh As Worksheet, rs As Object
    Set Sh = ThisWorkbook.Sheets("Форма_обновления")
    Dim irow As Long: irow = Sh.Cells(Rows.Count, 1).End(xlUp).Row
    If irow >= 2 Then
        Dim lColumnsCnt As Integer: lColumnsCnt = Sh.Cells(1, Sh.Columns.Count).End(xlToLeft).Column
        
        
        rx = Sh.Range(Sh.Cells(2, 1), Sh.Cells(irow, lColumnsCnt))
        Set Cn = CreateObject("ADODB.Connection")

        Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=\\keenetic_viva\DEZ-Disk\01Аналитика\1.2 база данных\1.2.10 Центральная база\" & bazname & ".accdb"
        If Cn.State <> 1 Then
            Exit Sub
        End If
        Set rs = CreateObject("ADODB.Recordset")
        rs.Open "SELECT [" & bazname & "].* FROM [" & bazname & "]", Cn, adOpenKeyset, adLockOptimistic
        
        Set q = Sh.Rows("1:1").Find(What:="Идентификатор", LookAt:=xlWhole)

        If Not q Is Nothing Then
            For i = 1 To UBound(rx, 2)
                If Sh.Cells(1, i) <> "Дата соглашения прописью" And Sh.Cells(1, i) <> "Дата первоначального взноса" Then
                    If Left(Sh.Cells(1, i), 4) = "Дата" Or Left(Sh.Cells(1, i), 5) = "Время" Then
                        Sh.Columns(i).TextToColumns Destination:=Sh.Cells(1, i)
                    End If
                End If
            Next i
On Error GoTo 100
            For n = 1 To UBound(rx)
                If rx(n, 1) <> "" Then
                    rs.AddNew
                    For i = 1 To UBound(rx, 2)
                        If rx(n, q.Column) <> "" Then
                            If Sh.Cells(1, i) = "Дата соглашения прописью" Or Sh.Cells(1, i) = "Дата первоначального взноса" Then
                                rs(i - 1) = rx(n, i)
                            Else
                                Select Case Left(Sh.Cells(1, i), 4)
                                Case "Дата", "Врем"
                                    rs(i - 1) = CDate(rx(n, i))
                                Case Else
                                    rs(i - 1) = rx(n, i)
200
                                End Select
                            End If
                        End If
                    Next
                End If
            Next
        End If
        rs.Update
        rs.Close
        Cn.Close
        Set rs = Nothing
        Set Cn = Nothing
    End If
Exit Sub
100
rs(i - 1) = CCur(rx(n, i))
GoTo 200
End Sub