Fantastish, Ваша ситуация оказалась сложнее.
1. В исходном файле несколько листов с взаимными связями
2. Формулы не всегда выдают корректный результат
Вот изменённый код с учетом особенностей Вашей таблицы.
Код:
![Выделить весь код](images/misc/selectcode.png)
Book = "Z:\Данные2.xlsx"
BookOut="Z:\форум_свобода.xlsx"
List = "Данные" ' Имя листа с данными
Col1 = "A" ' Первая колонка с данными
Col2 = "R" ' Последняя колонка с данными
Col0 = "F" ' Колонка с данными для анализа
Row1 = 2 ' Первая строка с данными
Set FSO = CreateObject("Scripting.FileSystemObject")
Set XL = CreateObject("Excel.Application")
With XL
.Visible = True
.Workbooks.Open Book
.Sheets(List).Select
.Range(Col1+":"+Col2).Copy
aaa=.Range(Col1+":"+Col2).PasteSpecial(-4163, -4142, False, False)
.Sheets(List).Copy
.Windows(FSO.GetFile(Book).Name).Close (False)
C1 = .Range(Col1 + "1").Column
C2 = .Range(Col2 + "1").Column
C0 = .Range(Col0 + "1").Column
R1 = Col1 + CStr(Row1)
i = Row1 - 1
Do
i = i + 1
L = False
For j = C1 To C2
On Error Resume Next
RR1=.Range(R1).Offset(i - Row1, j - C1)
If Err.Number <> 0 Then
RR1="Н/Д"
.Range(R1).Offset(i - Row1, j - C1)=RR1
End If
L = L Or RR1 <> ""
Next
If Not L Then Exit Do
Loop
Row2 = i - 1
' Dim Mas As Variant
Mas = .Range(R1 + ":" + Col2 + CStr(Row2))
.Range(R1 + ":" + Col2 + CStr(Row2)).ClearContents
N1 = LBound(Mas, 1)
N2 = UBound(Mas, 1)
N22 = UBound(Mas, 2) - LBound(Mas, 1)
R22 = Col1 + CStr(Row1) + ":" + Col2 + CStr(Row1)
ReDim Mas1(N22)
NN = 0
For i = N1 To N2
j = C0 - C1 + N1
If (Len(Trim(Mas(i, j))) = 0) Or (InStr(1, Mas(i, j), "Свобод") <> 0) Then
For jj = 0 To N22
Mas1(jj) = Mas(i, jj + N1)
Next
.Range(R22).Offset(NN, 0) = Mas1
NN = NN + 1
' MsgBox CStr(i) + " " + Mas(i, j)
End If
Next
.Range("A1").Select
If FSO.FileExists(BookOut) Then FSO.DeleteFile(BookOut)
.ActiveWorkbook.SaveAs BookOut
.Quit
End With
1. Формируется новая таблица с одним листом безо всяких формул
2. Игнорируются ошибки при работе Ваших формул