Sub Copy_File22()
Dim Книга As Workbook 'Сохранить измененные файлы
Dim sFileName As String, sNewFileName As String 'Копировать файлы
    ' Проходим через каждую рабочую книгу в коллекции Workbooks
    For Each Книга In Workbooks
        ' Проверяем, имеет ли книга путь сохранения
        If Книга.Path <> "" Then
            ' Проверяем, была ли книга изменена
            ' с момента последнего сохранения
            If Not Книга.Saved Then
                ' Если книга была изменена, сохраняем ее
                Книга.Save
            End If
            'Закрываем книгу
            Книга.Close False
        End If
    Next Книга
 
    sFileName = "C:\Users\***\Downloads\Книга1.xls"    'имя файла для копирования
    sNewFileName = "C:\Users\***\Downloads\!ПОИСК\Книга1.xls"    'имя копируемого файла.
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
    FileCopy sFileName, sNewFileName 'копируем файл
    
    sFileName = "C:\Users\***\Downloads\Книга2.xls"    'имя файла для копирования
    sNewFileName = "C:\Users\***\Downloads\!ПОИСК\Книга2.xls"    'имя копируемого файла.
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
    FileCopy sFileName, sNewFileName 'копируем файл
    
    'и далее по списку)
End Sub

Sub GetComboList()
Dim lRow&, I&
Dim arr()
Dim iTmp
With Sheets("Список_НД")
  lRow = .Cells(.Rows.Count, 5).End(xlUp).Row
  'забираем в массив значения из 5го и 6го столбцов
  'если хотите 'Да' записывать в столбце 'H', то нужно расширить диапазон до 8го столбца
  'arr = .Range(.Cells(4, 5), .Cells(lRow, 8)).Value
  'если в каком-то другом столбце, то соответственно до номера этого столбца
  arr = .Range(.Cells(4, 5), .Cells(lRow, 6)).Value '
End With
With CreateObject("Scripting.Dictionary")
  For I = LBound(arr, 1) To UBound(arr, 1)
    'тогда и в массиве нужно указывать не 2й 'столбец', а 4й
    'If arr(I, 4) = "Да" Then
    'ну и так далее
    If arr(I, 2) = "Да" Then
      iTmp = .Item(arr(I, 1))
    End If
  Next
  arrList = Application.Transpose(.Keys)
End With
End Sub

Sub TableFrom1C()
Dim arr(), newArr()
Dim I&, J&, N&, K&
On Error Resume Next
Application.ScreenUpdating = False
With Worksheets("Лист1")
  arr = .Range("A2:G" & .Cells(.Rows.Count, "C").End(xlUp).Row).Value
End With
ReDim newArr(LBound(arr, 1) To UBound(arr, 1), 1 To 7)
For I = LBound(arr, 1) To UBound(arr, 1)
  If arr(I, 1) <> "" Then
    N = N + 1
    newArr(N, 1) = arr(I, 1)
    newArr(N, 2) = arr(I, 2)
    newArr(N, 3) = arr(I, 4)
    newArr(N, 4) = arr(I, 5)
    newArr(N, 5) = arr(I, 6)
    newArr(N, 6) = arr(I, 7)
    newArr(N, 7) = arr(I, 3)
    K = 7
  Else
    K = K + 1
    If K > UBound(newArr, 2) Then
      ReDim Preserve newArr(LBound(newArr, 1) To UBound(newArr, 1), LBound(newArr, 2) To K)
    End If
    newArr(N, K) = arr(I, 3)
  End If
Next
With Worksheets("Лист2")
  .Range("A2").CurrentRegion.ClearContents
  .Range("A1").Resize(N, UBound(newArr, 2)) = newArr
  .Activate
End With
Application.ScreenUpdating = True
End Sub