Здравствуйте, для получения данных (лист отчета целиком) из другой книги собрал код, но он не работает не хочет рботать с открытой книгой. Общий доступ делать нельзя. Может нужно указать, что открыть только для чтения? 'Open Workbooks(Адрес6) For Input As #1 Но ошибка "subscript out of range"
Для проверки состояния книги позаимствовал функцию но она всегда выдает true, и при закрытой книге ?? пока не понял.
Код
Function IsBookOpen(wbFullName As String) As Boolean
Dim iFF As Integer
iFF = FreeFile
On Error Resume Next
Open wbFullName For Random Access Read Write Lock Read Write As #iFF
Close #iFF
IsBookOpen = Err
End Function
Код
Public Sub Получить6()
Dim Адрес6 As String
Dim Прграмма As Workbook
Dim Прил6 As Workbook
'On Error GoTo lable_1
Application.ScreenUpdating = False ' Отключаем “мерцание” окна
Set Прграмма = ThisWorkbook
Адрес6 = K:\Отчеты 1,2,3,4 кв\*.xls*"
If IsBookOpen(Адрес6) Then
Set Прил6 = Workbooks(Адрес6)
'Open Workbooks(Адрес6) For Input As #1
Else: Set Прил6 = Workbooks.Open(Адрес6)
End If
Application.DisplayAlerts = False
Прил6.Sheets("филиал 1").Copy After:=Прграмма.Worksheets(Прграмма.Worksheets.Count)
Application.DisplayAlerts = True
Прграмма.Sheets("Ожидаемые").Activate
Прил6.Close (False)
Application.ScreenUpdating = True ' Возвращаем режим обновления экрана при изменении
Exit Sub
MsgBox "Нет связи с базой данных," & Chr(13) _
& "возможно файл перемещен," & Chr(13) _
& "обратитесь к Андрею ))!!!", vbOKOnly + vbCritical
End Sub
Пока писал, додумался до макререкордера вот что получилось:
Код
Public Sub Получить6()
Dim Адрес6 As String
Dim Прграмма As Workbook
Dim Прил6 As Workbook
'On Error GoTo lable_1
Application.ScreenUpdating = False ' Отключаем “мерцание” окна
Set Прграмма = ThisWorkbook
Адрес6 = Прграмма.Worksheets("Const").Cells(1, 2) 'здесь должна быть маска K:\Отчеты 1,2,3,4 кв\*.xls*
Workbooks.Open Filename:=Адрес6, UpdateLinks:=0, Notify:=False
Set Прил6 = ActiveWorkbook
Прил6.Sheets("филиал 1").Copy After:=Прграмма.Worksheets(Прграмма.Worksheets.Count)
Прграмма.Sheets("Ожидаемые").Activate
Прил6.Close (False)
Application.ScreenUpdating = True ' Возвращаем режим обновления экрана при изменении
Exit Sub
MsgBox "Нет связи с базой данных," & Chr(13) _
& "возможно файл перемещен," & Chr(13) _
& "обратитесь к Андрею ))!!!", vbOKOnly + vbCritical
End Sub
Но и здесь проблема, если указать полный адрес, тогда все работае (только задает вопрос, типа Здесь уже работают, продолжить?), а если маску (файлы время от времени меняют, известно что в этой папке он один), то предупреждает что "файл открыт, попробуйте позже" и дальше ошибка на строчке Workbooks.Open Filename:=Адрес6, UpdateLinks:=0, Notify:=False
И как её открыть . если адрес указан маской? (для чтения и без вопросов [продолжить?])
Кажется справился, добавил цикл для поиска файла по маске, и получил полное имя файла.
Код
Public Sub Получить6()
Dim Адрес6 As String
Dim i As String
Dim Прграмма As Workbook
Dim Прил6 As Workbook
Dim ИмяФайла As String
On Error GoTo lable_1
Application.ScreenUpdating = False ' Отключаем “мерцание” окна
Set Прграмма = ThisWorkbook
Адрес6 = Прграмма.Worksheets("Const").Cells(1, 2) 'здесь должна быть маска K:\Отчеты 1,2,3,4 кв\*.xls*
'Workbooks.Open Filename:=Адрес6, UpdateLinks:=0, Notify:=False
ИмяФайла = Dir(Адрес6)
Do While ИмяФайла <> ""
If ИмяФайла Like "*xls*" Then
Адрес6 = Адрес6 & ИмяФайла
Exit Do
End If
ИмяФайла = Dir
Loop
Workbooks.Open Filename:=Адрес6, ReadOnly:=True, UpdateLinks:=0
Set Прил6 = ActiveWorkbook
Прил6.Sheets("филиал 1").Copy After:=Прграмма.Worksheets(Прграмма.Worksheets.Count)
Прграмма.Sheets("Ожидаемые").Activate
Прил6.Close (False)
Application.ScreenUpdating = True ' Возвращаем режим обновления экрана при изменении
Exit Sub
MsgBox "Нет связи с базой данных," & Chr(13) _
& "возможно файл перемещен," & Chr(13) _
& "обратитесь к Андрею ))!!!", vbOKOnly + vbCritical
End Sub
не хочет рботать с открытой книгой. Общий доступ делать нельзя. Может нужно указать, что открыть только для чтения? 'Open Workbooks(Адрес6) For Input As #1 Но ошибка "subscript out of range"