iLastCol = Cells(2, Columns.Count).End(xlToLeft).Column
    Columns("" & iLastCol - 30 & " :" & iLastCol & "").Select

Dim mm As Long
Dim yy As Long
Dim ml As Long

'mm ="[база.xlsm]Лист1!R8C16"
'ml ="[база.xlsm]Лист1!R8C18"
'yy ="[база.xlsm]Лист1!R8C17"

'ActiveSheet.Range(Cells(2,1), Cells(iLastRow, iLastCol)).AutoFilter Field:=28, Operator:= _
        xlFilterValues, Criteria2:=Array(1,"mm/ml/yy")

Windows("база_данных.xlsx").Activate

     iLastRow = Cells(Rows.Count, 1).End(xlUp).Row

   Cells("iLastRow+1, 32").Activate
'????????????????????????????????????????????????????????????????????????????????????????

    ActiveCell.FormulaR1C1 = "10"

   Cells("iLastRow,32").Select   
 '????????????????????????????????????????????????????????????????????????????????????????

    Selection.Copy

     iLastRow = Cells(Rows.Count, 32).End(xlUp).Row

     iLastRowRow = Cells(Rows.Count, 1).End(xlUp).Row

    Range(Cells(iLastRow + 1, 32), Cells(iLastRowRow,32)).Select

    Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _

AddRSet.Open AddSQL, pConn 

 TableRSet.Update 
ВЫДАЕТ
'BOF или EOF имеет значение True, либо текущая запись удалена. Для выполняемой операции требуется текущая запись '.

.Provider = "Microsoft.ACE.OLEDB.12.0" 

 SQLTextA = "insert into sale in values ('" & Cells(i, 2) & "','" & Cells(i, 3) & "','" & Cells(i, 4) & "','" & Cells(i, 5) & "','" & Cells(i, 6) & "','" & Cells(i, 7) & "','" & Cells(i, 8) & "','" & Cells(i, 9) & "','" & Cells(i, 10) & "')"

ADODB.Connection 

Public Sub ex2Access()
Dim BD As ADODB.Connection
Set BD = New ADODB.Connection
connStringA = "Data Source=V:\Reporting\FA SI\макросы\SI_Database.accdb"
With BD
.CommandTimeout = 20
.CursorLocation = adUseClient
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Open connStringA
End With
Dim commandsA As ADODB.Command
Set commandsA = New ADODB.Command
commandsA.ActiveConnection = connA
i = 2
Do While Cells(i, 1) <> ""
If Cells(i, 9) = "" Then GoTo 99
If Cells(i, 9) = " " Then GoTo 99
SQLTextA = "insert into sales values ('" & Cells(i, 2) & "','" & Cells(i, 3) & "','" & Cells(i, 4) & "','" & Cells(i, 5) & "','" & Cells(i, 6) & "','" & Cells(i, 7) & "','" & Cells(i, 8) & "','" & Cells(i, 9) & "','" & Cells(i, 10) & "')"
commandsA.CommandText = SQLTextA
commandsA.Execute
99
i = i + 1
Loop
End Sub

 Set BD = Workspaces(0).OpenDatabase("V:\Reporting\FA SI\макросыSI_Database.accdb")

Sub Macro4()
Dim i As Long
Dim iLastRow As Long

iLastRow = Cells(Rows.Count, 1).End(xlUp).Row

Cells(1, 19).Activate
ActiveCells.AutoFilter
ActiveSheet.Range(Cells(2, 19), Cells(iLastRow, 19)).AutoFilter Field:=19, Criteria1:="JUICE"
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells($$$$$, 19), Cells($$$$, 19)).Copy
Range(Cells($$$$$, 19), Cells($$$$$$, 19)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
     :=False, Transpose:=False
End Sub 

ActiveWorkbook.SaveAs Filename:="V:\Forecasting\" & Category & "\Прогноз продаж - " & Cells(2, 1) & " -неделя " & Cells(4,  & "-" & Cells(4, 15) & " (" & Category & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
 

 ActiveWorkbook.SaveAs Filename:="V:\Forecasting\" & Category & "\"& Cells (2,1)&"\Прогноз продаж - " & Cells(2, 1) & " -неделя " & Cells(4,  & "-" & Cells(4, 15) & " (" & Category & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

Sub Save()
    Set Category = Sheets(1).Cells(1, 1)
    Sheets("Output"    .Select
    Sheets("Output"    .Copy
    ActiveWorkbook.SaveAs Filename:="V:\Forecasting\" & Category & "\Прогноз продаж - " & Cells(2, 1) & " -неделя " & Cells(4,  & "-" & Cells(4, 15) & " (" & Category & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
 End Sub

Sub save_sbor()
Dim x As String
Dim file As String
Dim i As Integer
Dim b As Workbook
Dim c As String
       Set Category = Sheets(1).Cells(1, 1)
       Sheets("Output".Select
       Sheets("Output".Copy
       ActiveWorkbook.SaveAs Filename:="V:\Forecasting\" & Category & "\Прогноз продаж - " & Cells(2, 1) & " - неделя " & Cells(4,  & "-" & Cells(4, 15) & " (" & Category & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
       ActiveWindow.Close

x = "V:\Forecasting\" & Category & " ' по 85 файлов хранятся в папках типа V:\Forecasting\" Напитки "
file = Dir(x)
i = 1
Do While file <> ""
i = i + 1
Set b = Workbooks.Open(Filename:=x & file, UpdateLinks:=0)
c = b.Name
If c Like "Cells(2, 1)" Then b.SaveAs "V:\Forecasting\" & Category & "\Cells(2, 1)" & CStr(c) & ".xlsx"
'On Error Resume Next
b.Close savechanges:=False
file = Dir
Loop
End Sub