Код:
Sub KD5_Zapros()
a = Timer
Application.ScreenUpdating = False
'удаляем предыдущую базу если вдруг есть ==>
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(ActiveWorkbook.FullName & ".mdb") Then fso.DeleteFile ActiveWorkbook.FullName & ".mdb", True
'удаляем предыдущую базу если вдруг есть <==
Dim dbConnectStr As String
Dim Catalog As Object
Dim cnt As ADODB.Connection
Dim sCon$, rs As Object
Dim sSQL$
Set rs = CreateObject("ADODB.Recordset")
'Module5.sboboz 'сборочные шаблоны
'massoboz = Module5.oboz
ncolumn = Rows(1).Find(What:="Обозначение", LookIn:=xlValues, LookAt:=xlWhole).Column
Columns(ncolumn + 1).Insert
Cells(1, ncolumn + 1).Value = "Карточки"
'сортировка ====>
ActiveSheet.UsedRange.Select 'выделяем по тому что есть
If ActiveSheet.AutoFilterMode = False Then 'если нет фильтра - ставим
Selection.AutoFilter 'ставим фильтр
End If
ActiveWorkbook.Worksheets(ActiveSheet.Name).AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Range(Cells(1, ncolumn), Cells(Rows.Count, ncolumn)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets(ActiveSheet.Name).AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Selection.AutoFilter
Range("A1").Select
'сортировка <====
'создаем файл
Set Catalog = CreateObject("ADOX.Catalog")
Catalog.Create dbConnectStr
Set Catalog = Nothing
'запрос с листа ====>
Select Case CLng(Split(Application.Version, ".")(0))
Case Is < 12
sCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ActiveWorkbook.FullName _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
dbConnectStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ActiveWorkbook.FullName & ".mdb" & ";"
Case Is >= 12
sCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ActiveWorkbook.FullName _
& ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
dbConnectStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ActiveWorkbook.FullName & ".mdb" & ";"
End Select
Set cnt = New ADODB.Connection
'создаем таблицы ==>
With cnt
.Open dbConnectStr
.Execute "CREATE TABLE base ([Oboznach] text(50) WITH Compression, " & _
"[izm] text(50) WITH Compression, " & _
"[Count_page] text(50) WITH Compression)" 'таблица базы
End With
'создаем таблицы <==
'заполняем с листа ==>
sSQL = "SELECT [Обозначение] INTO list FROM [Excel 12.0;HDR=YES;IMEX=1;DATABASE=" & ActiveWorkbook.FullName & "].[" & ActiveSheet.Name & "$]"
Set rs = cnt.Execute(sSQL)
'заполняем с листа <==
'заполняем с сервера ==>
'Set conn = New ADODB.Connection
'conn.ConnectionString = "Provider=SQLOLEDB.1;Password=1qaz@WSX;Persist Security Info=True;User ID=User_for_macros_PDM;Initial Catalog=db_pdm_ScanKD;Data Source=RTVS-SQL05" 'Строка подключения
'conn.Open
'Set rst = New ADODB.Recordset
'rst.ActiveConnection = conn
'Ask = "SELECT [Oboznach],[izm],[Count_page], COUNT(*) as КоличествоЗаписей " _
'& "FROM [db_pdm_ScanKD].[dbo].[pdm_vwScanKD] " _
'& "Where Not ([Oboznach] Like '%ТУ' or [Oboznach] Like '%ИМ' or [Oboznach] Like '%ДИ' or [Oboznach] Like '%РР' or [Oboznach] Like '%РИ' or [Oboznach] Like '%УД' or [Oboznach] Like '%ЛУ' or [Oboznach] Like '%ТБ' or [Oboznach] Like '%Э3' or [Oboznach] Like '%ПЭ3' or [Oboznach] Like '%Д7' or [Oboznach] Like '%К3' or [Oboznach] Like '%Д4' or [Oboznach] Like '%ДП' or [Oboznach] Like '%РИ' or [Oboznach] Like '%ПГ3' or [Oboznach] Like '%ПГ4' or [Oboznach] Like '%Г4' or [Oboznach] Like '%ПГ3' or [Oboznach] Like '%Э4' or [Oboznach] Like '%ТЭ4' or [Oboznach] Like '%ПИ' or [Oboznach] Like '%И2') " _
'& " GROUP BY [Oboznach],[izm],[Count_page]"
'rst.Open Ask, conn, adOpenStatic, adLockBatchOptimistic
'arr1 = rst.GetRows
'conn.Closes
'заполняем с сервера <==
Application.ScreenUpdating = True
cnt.Close
MsgBox Timer - a
Stop
End Sub
