Sub RefreshPivot()
'
' RefreshPivot Macro
'
    Sheets("Sheet1").Select
    ActiveSheet.PivotTables("PivotTable1").PivotFields("Месяц"). _
        ClearAllFilters
    ActiveSheet.PivotTables("PivotTable1").PivotFields("Месяц").CurrentPage _
        = ThisWorkbook.Worksheets("Sheet1").Range("B57").Value
End Sub

Sub DWH_Update_12()
'Выгружаем в DWH
'Производит подключение к БД и выполняет какой-либо скрипт без подключение библиотеки ACTIVEX data ojects 6.0
'
Dim cn As Object
Dim cmd As Object
Dim strSQL As String
Dim sh1 As Worksheet
Dim iRow As Long
Dim ADOErr, r

Set cn = CreateObject("ADODB.Connection")
'cn.Provider = "Microsoft.Jet.OLEDB.4.0"
cn.ConnectionString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Initial Catalog=usr;Data Source=dc1-findb01\fin;Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;Workstation ID=MP1806SV;Use Encryption for Data=False;Tag with column collation when possible=False"
 
 
On Error GoTo CnErrorHandler
cn.Open
'Явно начинаем транзакцию во избежание режима AutoCommit=ON
cn.BeginTrans
 
'Создаем команду
Set cmd = CreateObject("ADODB.Command")
cmd.ActiveConnection = cn
'
Workbooks("Pushkin_card.xlsm").Activate
Set sh1 = ActiveWorkbook.Sheets("Встречи")
sh1.[A1].Select
Set r = ActiveCell.CurrentRegion
'
For iRow = 2 To r.Rows.Count

cmd.CommandText = "Insert into usr.supr.checkin_b(" _
& "kod,kod_prm,MR,OC,locality,adress,Open_PRM,number_of_windows_b,Format ,Col1,Col2,Col3,Col4,Col5,Col6,Col7,Col8,Col9,Col10,Col11,Col12,Col13,Col14,Col15, Col16, Col17, Col18, Col19, Col20, Col21, Col22, Col23, Col24, Col25, Col26, Col27, Col28, Col29, Col30, Col31, Col32" _
& ")Values (" _
& "convert(float,(replace('" & Cells(iRow, 1).Value & "',',','.')))," & "convert(float,(replace('" & Cells(iRow, 2).Value & "',',','.')))," '" & .Cells(iRow, 3) &, "'& "convert(datetime,(replace('" & Cells(iRow, 3).Value & "','dd.mm.yyyy','yyyy-mm-dd')),103)," & "convert(float,(replace('" & Cells(iRow, 5).Value & "',',','.'))))"
'
'MsgBox cmd.CommandText
'test = r.Cells(iRow, 2).Value
'MsgBox "Iter: " & iRow & " " & test
'
cmd.Execute
'
Next iRow
'
cn.CommitTrans
'
cn.Close
'
Exit Sub
'
CnErrorHandler:
For Each ADOErr In cn.Errors        'Отладчик ошибок подключения
    MsgBox "№ ошибки " & ADOErr.Number & Chr(10) & _
    "Описание: " & ADOErr.Description & Chr(10) & _
    "Источник: " & ADOErr.Source, vbCritical
    Debug.Print "№ ошибки " & ADOErr.Number & Chr(10) & _
    "Описание: " & ADOErr.Description & Chr(10) & _
    "Источник: " & ADOErr.Source
Next
cn.Close
Set cn = Nothing
'
End Sub

Public Sub test()

Dim I, J As Integer
Dim Vintage1() As Variant
Dim WCur As Worksheet
Dim WbN As Workbook

'формируется массив
RowCount = 0
RowCount = Cells(2, 2).End(xlDown).Row
RowColumn = Cells(2, 1).End(xlToLeft).Row
ReDim Vintage1(RowCount, 1)
For I = 1 To RowColumn - 1
For J = 1 To RowCount
Vintage1(J, I) = Cells(J + 2, I + 1).Select
Next J
Next I

'Написала примерный код для копирования на другой лист, но он не работает
'Set WbN = Workbooks.Add(xlWBATWorksheet)

'WCur.Vintage1(xlCellTypeVisible).Copy

'WbN.SaveAs ThisWorkbook.Path & "\" & IName & ".xls"
'WbN.Close SaveChanges:=True
'Next
'Application.ScreenUpdating = True

End Sub

Sub DWH_Update_22()
'Выгружаем в DWH
'Производит подключение к БД и выполняет какой-либо скрипт без подключение библиотеки ACTIVEX data ojects 6.0
'
Dim cn As Object
Dim cmd As Object
Dim strSQL As String
Dim sh1 As Worksheet
Dim iRow As Long
Dim ADOErr, r

Set cn = CreateObject("ADODB.Connection")
cn.ConnectionString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Initial Catalog=usr;Data Source= название подключения;Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;Workstation ID=MP1806SV;Use Encryption for Data=False;Tag with column collation when possible=False"


On Error GoTo CnErrorHandler
cn.Open
'Явно начинаем транзакцию во избежание режима AutoCommit=ON
cn.BeginTrans

'Создаем команду
Set cmd = CreateObject("ADODB.Command")
cmd.ActiveConnection = cn
'
Workbooks("Название файла из которого выгружаются данные").Activate
Set sh1 = ActiveWorkbook.Sheets("Название листа")
sh1.[A1].Select
Set r = ActiveCell.CurrentRegion
'
For iRow = 2 To r.Rows.Count

cmd.CommandText = "Insert into название таблицы в БД (" _
& "имя полей, которые выгружать" _
& ")Values (" _
& "'" & Cells(iRow, 3).Value & "'," & "'" & Cells(iRow, 4).Value & "'," & "convert(datetime,(replace('" & Cells(iRow, 5).Value & "','dd.mm.yyyy','yyyy-mm-dd')),103))"
'

cmd.Execute
'
Next iRow
'
cn.CommitTrans
'
cn.Close
'
Exit Sub
'
CnErrorHandler:
For Each ADOErr In cn.Errors        'Отладчик ошибок подключения
    MsgBox "№ ошибки " & ADOErr.Number & Chr(10) & _
    "Описание: " & ADOErr.Description & Chr(10) & _
    "Источник: " & ADOErr.Source, vbCritical
    Debug.Print "№ ошибки " & ADOErr.Number & Chr(10) & _
    "Описание: " & ADOErr.Description & Chr(10) & _
    "Источник: " & ADOErr.Source
Next
cn.Close
Set cn = Nothing
'
End Sub

Public Sub Email_dir()
Dim objOutlook As Object, objMail As Object
Dim sTo As String, sSubject As String, sBody As String, sAttachment As String, sPicture As String
Dim I, J, X As Integer
Dim Part, RowCount, Counter As Variant
Dim Vintage1(), Vintage2() As Variant
'
Workbooks.Open Filename:="X:\....xlsm"
Sheets("...").Select
RowCount = 0
End(xlDown).Row
RowCount = Cells(2, 2).End(xlDown).Row
For X = 2 To RowCount
sTo = Cells(X, 2)
'
Sheets("...").Select

RowCount = 0
End(xlDown).Row
RowCount = Cells(2, 2).End(xlDown).Row
ReDim Vintage1(RowCount, 2)
'
For I = 1 To RowCount
For J = 2 To 3
'
Vintage1(I, J - 1) = Cells(I + 1, J)
Next J
Next I
'
ReDim Vintage2(RowCount, 1)
'
For I = 1 To RowCount
If Vintage1(I, 1) = sTo Then
Vintage2(I, 1) = Vintage1(I, 2)

End If
Next I

For I = 1 To RowCount

sBody = sBody & Vintage2(I, 1) & "<br>"
Next I
'
If objOutlook Is Nothing Then
Set objOutlook = CreateObject("Outlook.Application")
End If
'
Set objOutlook = GetObject(, "Outlook.Application")
Err.Clear
Set objMail = objOutlook.CreateItem(0)
If Err.Number <> 0 Then Set objOutlook = Nothing: Set objMail = Nothing: Exit Sub
'
sSubject = ...
sPicture = "..."

With objMail
.To = sTo 
.CC = "" 
.BCC = ""
.Subject = sSubject 
.HTMLBody = sBody 

If Dir(sPicture, 16) <> "" Then
.Attachments.Add sPicture

.HTMLBody = .HTMLBody _
& "<p></p>" _
& "<img src=cid:" & Replace(Dir(sPicture, 16), " ", "%20") & ">" _
& "<p><i>...</i></p>"
'" height=240 width=180>" 
End If
If sAttachment <> "" Then
If Dir(sAttachment, 16) <> "" Then
.Attachments.Add sAttachment 
End If
End If
.Send 
End With
'
Set objOutlook = Nothing: Set objMail = Nothing
Application.ScreenUpdating = True
'
sBody = ""
Erase Vintage1
Erase Vintage2
Sheets("Ñîòð").Select
Next X

'
'Windows("Procedure_trigger.xlsm").Activate
'Sheets("ÄÊÖ").Select
ActiveWorkbook.Save
'
'Application.Quit
End Sub