Помогите разобраться пожалуйста.
При выполнении приложенного макроса (или похожих на него, использующих поочередное открытие файлов) после открытия последнего файла в папке появляется окно "Свойства канала передачи данных", требующего указать какой-то источник данных. При рандомном указании источника и нажатии на ОК окно закрывается и макрос прерывается. Просто мне непонятно, откуда окно и что там указывать.
Макрос делает следующую операцию - сверяет в каждом файле указанной юзером папки в указанной пользователем вкладке данные с исходным файлом. ОШибка может как возникать, так и не возникать, если для проверки выбирать разные папки.
Кто-нибудь с таким сталкивался? С чем связа
| Код |
|---|
Sub CHECK_DATA()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim katal As Variant
Dim CompareRange As Variant, x As Variant, y As Variant
Dim n As Long
'Dim Ofrange As Long
Dim input_sheet As String
input_sheet = InputBox("введите период(название листа) для проверки")
katal = GetFolderPath("Укажите каталог с файлами", ThisWorkbook.Path)
If katal <> "" Then
Dim FS, KATALOG, FILE, MASSIV As Object
Set FS = CreateObject("Scripting.FileSystemObject")
Set KATALOG = FS.GetFolder(katal)
Set MASSIV = KATALOG.Files
Range("B12").Select
n = Empty
Do While Range("B12").Offset(1 + n) <> Empty
Range("B12").Offset(1 + n, 18).Value = Range("B12").Offset(1 + n).Value & " " & Range("B12").Offset(1 + n, 3).Value
n = n + 1
Loop
Range("B12").Select
Set Rng = Range(Selection, Selection.End(xlDown)).Offset(0, 18) ' выбираем в сводном файле диапазон КР+запчасть для сверки
' If Rng.Cells.Count > 20000 Then Exit Sub
For Each FILE In MASSIV 'пробегаемся по каждому файлу из папки
Workbooks.Open Filename:=FILE
On Error Resume Next
If ActiveWorkbook.Name <> "файл1.xlsm" Then
If Sheets(input_sheet) Is Nothing Then
GoTo lastline
Else
Sheets(input_sheet).Activate
Range("A1:C2000").Find("Код ЗЧ", LookIn:=xlValues).Select 'цикл поиска таблицы РТВ по привязке к коду ЗЧ
If Selection Is Nothing Then
GoTo lastline
Else
Set CompareRange = Range(Selection, Selection.End(xlDown))
For Each x In Rng
For Each y In CompareRange
y.Offset(0, 9).Value = y.Value & " " & y.Offset(0, 3).Value
If x.Value = y.Offset(0, 9).Value Then x.Offset(0, -18).Interior.Color = y.Interior.Color
Next y
Next x
End If
End If
End If
lastline:
ActiveWorkbook.Close (False)
Next FILE
MsgBox "Готово"
Columns("T:T").Delete
Else
MsgBox "Каталог не выбран"
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", _
Optional ByVal InitialPath As String = "c:\", _
Optional ByVal FilterDescription As String = "Файлы Excel", _
Optional ByVal FilterExtention As String = "*.xlsm*") As String
Dim PS As String: PS = Application.PathSeparator
With Application.FileDialog(msoFileDialogFolderPicker)
If Not Right$(InitialPath, 1) = PS Then InitialPath = InitialPath & PS
.ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
If .Show <> -1 Then Exit Function
GetFolderPath = .SelectedItems(1)
If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
End With
End Function
|
