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
|
