' определяю последнюю строку в базе для копирования
LR2 = ThisWorkbook.Worksheets("БазаДляКопир").Cells(Rows.Count, 1).End(xlUp).Row '
 

 ' определяю последнюю строку в базе для вставки
LR1 = ThisWorkbook.Worksheets("БазаДляВставки").Cells(Rows.Count, 7).End(xlUp).Row '



    Application.ScreenUpdating = False
    Application.ShowWindowsInTaskbar = False
    Application.EnableEvents = False



 ' определяю массив ARR1  - массив данных, которые будут копироваться и массив ARR2 - массив, куда все будет вставляться
 ThisWorkbook.Worksheets("БазаДляКопир").Activate
ARR1 = ThisWorkbook.Worksheets("БазаДляКопир").Range(Cells(2, 1), Cells(LR1, 12)).Value


ThisWorkbook.Worksheets("БазаДляВставки").Activate
ARR2 = ThisWorkbook.Worksheets("БазаДляВставки").Range(Cells(2, 17), Cells(LR2, 27)).Value
 

'в массиве ARR2 , куда планирую вставлять данные ищу те строки, где данные нужно заполнить (если в ячейке с описанием изделия пусто, значит, надо обработать)
        For i = 1 To UBound(ARR2)
           If ARR2(i, 2) = "" Then

' в массиве ARR1 ищу нужные данные по столбцам от 1 до 11
                   For j = 1 To UBound(ARR1)
                       If ARR2(i, 1) = ARR1(j, 7) Then
                             Desc = ARR1(j, 8)
                             TypeFabric = ARR1(j, 3)
                             AgeSex = ARR1(j, 1)
                             HTS = ARR1(j, 2)
                             Fabric = ARR1(j, 4)
                             CC = ARR1(j, 5)
                             DC = ARR1(j, 6)
                             Pic = ARR1(j, 9)
                             SizeUS = ARR1(j, 10)
                             SizeRU = ARR1(j, 11)
                       End If
                   Next
                    ARR2(i, 2) = Desc
                    ARR2(i, 3) = TypeFabric
                    ARR2(i, 4) = AgeSex
                    ARR2(i, 5) = Fabric
                    ARR2(i, 6) = SizeUS
                    ARR2(i, 7) = SizeRU
                    ARR2(i, 8) = HTS
                    ARR2(i, 9) = CC
                    ARR2(i, 10) = DC
                    ARR2(i, 11) = Pic
              End If
          
       Next


' вставляю данные 
With Range(Cells(2, 17), Cells(LR2, 27))
 .ClearContents
  .Value = ARR2
End With

' определяем массив
    MyArr = Range("A1", Cells.SpecialCells(11)).Value

' происк провожу по 1 строке по всем столбцам (это шапка таблицы с заголовками)
 For lc = 1 To UBound(avArr, 2)
        
'через условие в массиве ищу ячейку, где встречается нужное значение и передаю в переменную номер найденного столбца 
            If MyArr(lr, lc) = "Страна происхождения" Then
' передаю в переменную iCOO номер столбца, где в заголовке "страна происхождения" 
             iCOO = Cells(lr, lc).Column
            End If
            If MyArr(lr, lc) = "Наименование" Then
' передаю в переменную iDescr номер столбца, где в заголовке "Наименование" 
            iDescr = Cells(lr, lc).Column
            End If
            If MyArr(lr, lc) = "Название завода" Then
' передаю в переменную iFactory номер столбца, где в заголовке "Название завода" 
            iFactory = Cells(lr, lc).Column
            End If
  Next lc

    With Sheets("Адреса")
      jLastRow = ThisWorkbook.Sheets("Адреса").Cells(Rows.Count, 1).End(xlUp).Row  

        For i = 3 To jLastRow
               Set rRange = .Cells(i, 1)
                 n11 = InStr(1, rRange, """")
                 n22 = InStr(n11 + 1, rRange, """")
                 AddressName = Right(rRange, n22 + 1)

        Next
    End With

For f = 1 To ListFolders.ListCount
    n = 0
    fpatch = ListFolders.List(f - 1)
    Set fso = CreateObject("scripting.filesystemobject")
    Set sfol_1 = fso.GetFolder(fpatch)
If fpatch <> 0 Then
           For Each sfol_2 In sfol_1.SubFolders
                If sfol_2.Name = "на печать" Or sfol_2.Name = "НА ПЕЧАТЬ" Or sfol_2.Name = "На печать" Or sfol_2.Name = "Для печати" Or sfol_2.Name = "ДЛЯ ПЕЧАТИ" Or sfol_2.Name = "для печати" Then
                    For Each fil In sfol_2.Files
                        If fil.Name Like "*SPEC.xls*" Or fil.Name Like "*SPECIF.xls" Or fil.Name Like "*SPECIF.xlsx" Or fil.Name Like "*SPEC.xlsx*" Then
 
               ПРОЦЕДУРА РАБОТЫ С ОТКРЫТЫМ ФАЙЛОМ

            End If
                    Next
                    
                End If
          Next
End If
Next f

        For r = lastrow To 1 Step -1
            If Application.CountA(Cells(r, 1)) = 0 Then Rows(r).Delete
            If Application.CountA(Cells(r, 1)) = "" Then Rows(r).Delete
        Next r 

    For Each cellC In InfoRG
        If Len(cellC) > 30 Then
            ThisWorkbook.Worksheets("test").Cells(cellC.Row, 2) = Mid(cellC, 1, 30)
            ThisWorkbook.Worksheets("test").Cells(cellC.Row, 3) = Mid(cellC, 31)
        Else
            ThisWorkbook.Worksheets("test").Cells(cellC.Row, 2) = cellC
            ThisWorkbook.Worksheets("test").Cells(cellC.Row, 3) = "."
        End If
    Next cellC 

Set FoundRng = Columns("C:C").Find(What:=iNomerDoc, LookIn:=xlFormulas, LookAt:=xlWhole)   
if Not FoundRng Is Nothing Then   
If FoundRng.Offset(0,-2).Value=iNomerDoc2 Then MsgBox "Нашел"   
endif 

If FoundRng.Offset(0,-2).Value=iNomerDoc2

Sub MyCode ()


ChDir _
    "C:\Users\C\Desktop\FOLDER"    
Workbooks.Open Filename:= _
    "C:\Users\Í\Desktop\FOLDER\FILENew.xls" 

дальше код работы с открытым файлом

Sub MyCode ()


ChDir _
    "Y:\Public\Folder1"

Workbooks.Open Filename:= _
    "Y:\Public\Folder1\FILENew.xls" 

дальше код работы с открытым файлом

Sub MyCode ()

On error resume next
ChDir _
    "Y:\Public\Folder1"

Workbooks.Open Filename:= _
    "Y:\Public\Folder1\FILENew.xls" 

ChDir _
    "C:\Users\C\Desktop\FOLDER"    
Workbooks.Open Filename:= _
    "C:\Users\Í\Desktop\FOLDER\FILENew.xls" 
on error goto 0

дальше код работы с открытым файлом

 Workbooks.OpenText Filename:="C:\Users\Í\Desktop\test.txt", Origin _
 :=866, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote _
 , ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False _
 , Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 1 _
 ), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1)), _
 TrailingMinusNumbers:=True