Microsoft Excel:

  Таблицы и VBA. Справочник.
  Вопросы и Ответы. Советы. Примеры.
Меню FAQ | Макросы | Workbooks & FileSystem


Rambler's Top100


Counter CO.KZ


    [1] [2] [3]

  1. Как определить путь к файлу (текущую папку) ?
    Как определить папку в которой установлен MS Excel ?
    2004
  2. Как определить каталог в котором установлена OC Windows ? 02.10.2006
  3. Как определить временный каталог Windows ? 29.07.2009
  4. Как определить размер файла ? 30.06.2007
  5. Как определить дату создания или последнего изменения файла ? 30.06.2007
  6. Как определить дату создания папки ? 31.08.2007
  7. Как определить имеет ли файл атрибут скрытый и/или только для чтения ? 16.07.2007
  8. Как программно установить режим Только для чтения ? 08.12.2007
  9. Как определить какие файлы открывались последними ? 11.06.2007
  10. Как определить наличие или отсутствие активной рабочей книги ? 02.02.2008
  11. Как определить открыта или нет нужная рабочая книга ? 17.05.2006
  12. Как определить существует или нет файл по указанному адресу ? 13.04.2005
  13. Как определить наличие папки, каталога ? 21.12.2005
  14. Как определить наличие ссылок на другие рабочие книги ? 21.12.2005
  15. Как программно обновить внешние ссылки ? 14.09.2007
  16. Как программно заменить ссылку на одну книгу - другой книгой ? NEW 17.09.2016
  17. Как программно открыть существующие рабочие книги, с которыми связана текущая книга ? 26.01.2008
  18. Как программно найти "битые" внешние xls ссылки ? 27.06.2014
  19. Как заменить внешние ссылки на значения, которые эти формулы возвращают (во всех листах) ? 08.01.2016
  20. Как определить наличие несохранённых изменений в рабочей книге ? 31.07.2006
  21. Как определить наличие личной книги макросов Personal.xls ? 19.08.2006
  22. Как определить текущий путь ? 06.01.2008
  23. Как определить имя файла ? 2004
  24. Как сделать, чтобы в заголовке окна книги появлялось полное имя книги ? 24.07.2011
  25. Как добавить ссылку на рабочую книгу в папку Избранное ? 27.02.2011
  26. Как получить или изменить нужное свойство рабочей книги ? 22.06.2007
  27. Как создать, изменить и получить пользовательское свойство рабочей книги ? 30.06.2007
  28. Как автоматически изменять стиль ссылок с R1C1 на A1 ? 13.09.2007
  29. Как отслеживать открытие и создание рабочих книг, и создавать ежедневный отчёт о этих действиях ? 10.06.2010
    [1] [2] [3]


  • Ответ :
  • iPath = ThisWorkbook.Path
    iPath = ActiveWorkbook.Path
    iExcel = Application.Path
  • В первом примере указан путь к файлу, где содержится сама программа, которая в настоящий момент выполняет код VBA.
  • Во втором примере указан путь к активному файлу.
  • В третьем примере указан путь к папке, в которой установлен MS Excel. При наличии у Вас нескольких версий, укажет путь к версии, в которой Вы работаете в данный момент.

    Комментарий : Только что созданная и не сохранённая рабочая книга (файл) не имеет папки, а значит iPath = ""
  • Ответ :
  • iWinDir = Environ("WinDir")

  • Ответ :
  • iTempDir = Environ("Temp")

  • Ответ :
  • iFullName = "C:\Temp\Test.xls"

    iFileSize = FileLen(iFullName)

    MsgBox "Размер файла составляет : " & iFileSize & " байт", , ""
    Примечание :
  • Не забудьте предварительно проверить наличие указанного файла [FAQ44]
  • Если указанный файл открыт, то функция FileLen() возвратит размер файла до его открытия.
  • Ответ :
  • iFullName = "C:\Temp\Test.xls"

    iFileDateTime = FileDateTime(iFullName)

    MsgBox "Дата создания или последнего изменения : " & iFileDateTime, , ""
    Примечание : Не забудьте предварительно проверить наличие указанного файла [FAQ44]
  • Ответ :
  • iPath = "C:\Мои документы"

    iFileDateTime = FileDateTime(iPath)

    MsgBox "Дата создания папки : " & iFileDateTime, , ""
    Примечание : Не забудьте предварительно проверить наличие указанной папки [FAQ65]
  • Ответ :
  • iFullName = "C:\Temp\Test.xls"

    If (GetAttr(iFullName) And vbHidden + vbReadOnly) <> 0 Then _
        MsgBox "Атрибуты Скрытый и Только_для_чтения установлены"
    iFullName = "C:\WINDOWS\WINPOPUP.EXE"

    iResult = GetAttr(iFullName)

    If (iResult And vbHidden) <> 0 Then _
        MsgBox "Атрибут Скрытый установлен"

    If (iResult And vbArchive) <> 0 Then _
        MsgBox "Атрибут Архивный установлен"

    If (iResult And vbReadOnly) <> 0 Then _
        MsgBox "Атрибут Только_для_чтения установлен"
    Примечание : Не забудьте предварительно проверить наличие указанного файла [FAQ44]
  • Ответ :

    Если для нужной открытой рабочей книги, необходимо программно установить режим "Только для чтения", то для этого, можно воспользоваться методом ChangeFileAccess об'екта Workbook
  • ThisWorkbook.ChangeFileAccess Mode:=xlReadOnly
    Комментарий :
  • Выполнение этой инструкции приведёт к появлению стандартного диалогового окна, предлагающего сохранить изменения перед переключением статуса.
  • Текущую книгу ThisWorkbook можно заменить любой другой открытой рабочей книгой, но эта книга обязательно должна быть сохранена.
  • Если рабочая книга уже доступна только для чтения, то попытка изменить её статус на "Только для чтения" приведёт к возникновению ошибки.

    Всех вышеперечисленных проблем можно избежать, если воспользоваться следующим вариантом :
  • With Application
         .DisplayAlerts = False
         With .ThisWorkbook
              If Not .ReadOnly Then .ChangeFileAccess Mode:=xlReadOnly
         End With
         .DisplayAlerts = True
    End With
    Если же речь идёт о закрытой рабочей книге, то для того, чтобы открыть эту книгу в режиме "Только для чтения" достаточно использовать необязательный именованный аргумент ReadOnly метода Open
    iFullName = "C:\Temp\Test.xls"

    Workbooks.Open FileName:=iFullName, ReadOnly:=True
    Примечание : Не забудьте предварительно проверить наличие указанного файла [FAQ44], и при необходимости использовать и другие аргументы используемого метода : Password (если книга защищена паролем), UpdateLinks (если книга содержит внешние ссылки) и т.д.
  • Ответ : Актуально для MS Excel 97-2007

    Если Вы не отключили соответствующую опцию [FAQ], то используя семейство RecentFile, Вы сможете получить список последних открывавшихся файлов.
    Обратите внимание на то, что количество файлов в этом списке также зависит от вышеупомянутого свойства, кроме того, существует вероятность, что на момент выполнения макроса, любой из файлов может быть ещё открыт.
  • Private Sub getRecentFiles_xl97()
        Dim iRecentFile As RecentFile
        For Each iRecentFile In Application.RecentFiles
            MsgBox "Имя книги : " & iRecentFile.Name
            MsgBox "Папка : " & iRecentFile.Path
        Next
    End Sub
    Особенности Microsoft Excel 2007

    В этой версии, максимальное количество последних открывавшихся файлов, было увеличено до 50. Причём, в реестре реально хранятся данные всех 50, поэтому, в отличии от прошлых версий, здесь мы можем получить весь список, т.е.
    Private Sub getRecentFiles_xl2007()
        Dim iRecentFile As RecentFile, oldValue&
        
        oldValue = Application.RecentFiles.Maximum
        Application.RecentFiles.Maximum = 50
        
        For Each iRecentFile In Application.RecentFiles
            MsgBox "Имя книги : " & iRecentFile.Name
            MsgBox "Папка : " & iRecentFile.Path
        Next
    
        Application.RecentFiles.Maximum = oldValue
    End Sub
    P.S. Если же Вам проще получить имена последних открывавшихся файлов, непосредственно из реестра, то ниже приведены имена разделов, где хранится эта информация. Обратите внимание на то, что местохранение информации различается, т.к. зависит от версии офиса.
    HKEY_CURRENT_USER\Software\Microsoft\Office\8.0\Excel\Recent File List
    HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Excel\Recent Files
    HKEY_CURRENT_USER\Software\Microsoft\Office\10.0\Excel\Recent Files
    HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Excel\Recent Files
    HKEY_CURRENT_USER\Software\Microsoft\Office\12.0\Excel\File MRU

  • Ответ :

    Вариант I. (без 'генерации' ошибки)
  • Option Compare Text 'Если Вы не понимаете, зачем используется эта инструкция, то оставьте её в покое

    Private Function WorkbookIsOpen(iName$) As Boolean
    '***********************************************'
    '   Дата создания 01/01/2005
    '   Автор Климов Павел Юрьевич
    '   http://www.msoffice.nm.ru
    '***********************************************'
        Dim iBook As Workbook
        For Each iBook In Workbooks
            If iBook.Name = iName$ Then
               WorkbookIsOpen = True
               Exit Function
            End If
        Next
        WorkbookIsOpen = False
    End Function
    Private Function WorkbookIsOpen(iName$) As Boolean
    '***********************************************'
    '   Дата создания 01/01/2005
    '   Автор Климов Павел Юрьевич
    '   http://www.msoffice.nm.ru
    '***********************************************'
        Dim iBook As Workbook
        For Each iBook In Workbooks
            If StrComp(iBook.Name, iName$, vbTextCompare) = 0 Then
               WorkbookIsOpen = True
               Exit Function
            End If
        Next
        WorkbookIsOpen = False
    End Function
    Вариант II.
    Private Function WorkbookIsOpen(iName$) As Boolean
    '***********************************************'
    '   Дата создания 01/01/2005
    '   Автор Климов Павел Юрьевич
    '   http://www.msoffice.nm.ru
    '***********************************************'
        On Error Resume Next
        WorkbookIsOpen = IsObject(Workbooks(iName$))
    End Function
    Private Function WorkbookIsOpen(iName$) As Boolean
        On Error Resume Next
        WorkbookIsOpen = (TypeOf Workbooks(iName$) Is Workbook)
    End Function
    Private Function WorkbookIsOpen(iName$) As Boolean
        On Error Resume Next
        WorkbookIsOpen = (TypeName(Workbooks(iName$)) = "Workbook")
    End Function
    Private Function WorkbookIsOpen(iName$) As Boolean
        On Error Resume Next
        WorkbookIsOpen = (VarType(Workbooks(iName$)) = vbObject)
    End Function
    Private Function WorkbookIsOpen(iName$) As Boolean
        On Error Resume Next
        WorkbookIsOpen = Len(Workbooks(iName$).Name) > 0
    End Function
    Private Function WorkbookIsOpen(iName$) As Boolean
        On Error Resume Next
        WorkbookIsOpen = Workbooks(iName$).Index > 0
    End Function
    Пример вызова любой из вышеопубликованных авторских функций :
    Private Sub Test()
        MsgBox WorkbookIsOpen("Имя_Книги.xls")
    End Sub
    Примечание : Если необходимо активировать рабочую книгу, то можно использовать такой вариант :
    Private Sub Workbook_Active()
    On Error GoTo ErrHandler
        Workbooks("Квартальный отчёт.xls").Activate
        Exit Sub

    ErrHandler:
        MsgBox "Рабочая книга закрыта", , "Ошибка пользователя !!!"
    End Sub
    Вариант III.
    Private Function WorkbookIsOpen(iName$) As Boolean
        WorkbookIsOpen = _
        Not IsError(ExecuteExcel4Macro("DOCUMENTS(3,""" & iName$ & """)"))
    End Function
    iName = "Personal.xls"
    iMacroFunction = "DOCUMENTS(3,""" & iName & """)"
    iWorkbookName = ExecuteExcel4Macro(iMacroFunction)

    If Not IsError(iWorkbookName) Then
       MsgBox "Рабочая книга открыта"
    Else
       MsgBox "Рабочая книга закрыта"
    End If

  • Ответ :

    Вариант I. (полный)
  • iFileName = "Sample.xls"
    iFullName = "C:\Excel\Sample.xls"

    If iFileName = Dir(iFullName) Then
       MsgBox "Файл : " & iFileName & " найден"
    Else
       MsgBox "Файл : " & iFileName & " не найден"
    End If
    Вариант II. (сокращённый)
    iFullName = "C:\Excel\Sample.xls"

    If Dir(iFullName) <> "" Then
       MsgBox "Файл : " & iFullName & " найден"
    Else
       MsgBox "Файл : " & iFullName & " не найден"
    End If
    Вариант III.
    iFullName = "C:\Excel\Sample.xls"
    iMacroFunction = "Files(""" & iFullName & """)"
    iFileName = ExecuteExcel4Macro(iMacroFunction)

    If Not IsError(iFileName) Then
       MsgBox "Файл : " & iFileName & " найден"
    Else
       MsgBox "Файл : " & iFullName & " не найден"
    End If

  • Ответ :
  • iPath = "C:\Archive\" ' "C:\Archive"

    If Dir(iPath, vbDirectory) <> "" Then
       MsgBox "Папка : " & iPath & " найдена"
    Else
       MsgBox "Папка : " & iPath & " не найдена"
    End If
    Вариант II. Михаил Жилин MS MVP (http://mikhail-z.narod.ru, http://www.aha.ru/~mwz) для проверки существования папок, например, c:\test предлагает использовать VB(A) функцию Dir() и псевдофайл NUL
    Dim retval
    retval = Dir("c:\test\nul")
    Debug.Print retval

  • Ответ :

    Вариант I.
  • iExcelLinks = ThisWorkbook.LinkSources(xlExcelLinks)
    If IsArray(iExcelLinks) = True Then
       If MsgBox("Рабочая книга содержит внешние ссылки" & vbCrLf & _
          "Хотите посмотреть список исходных файлов ?", vbYesNo) = vbYes Then
          For Each iLink In iExcelLinks
              iLinks = iLinks & vbCrLf & iLink
          Next
          MsgBox "Список исходных файлов : " & iLinks
       End If
    Else
       MsgBox "Рабочая книга не содержит внешних ссылок"
    End If
    Вариант II.
    If Not IsError(ExecuteExcel4Macro("Links()")) Then
       If MsgBox("Рабочая книга содержит ссылки на .XL файлы" & vbCrLf & _
          "Хотите посмотреть список этих файлов ?", vbYesNo) = vbYes Then
          ThisWorkbook.Names.Add Name:="ExcelLinks", RefersTo:="=Links()"
          iExcelLinks = Evaluate("ExcelLinks")
          For Each iLink In iExcelLinks
              iLinks = iLinks & vbCrLf & iLink
          Next
          MsgBox "Список исходных файлов : " & iLinks
          ThisWorkbook.Names("ExcelLinks").Delete
       End If
    Else
       MsgBox "Рабочая книга не содержит ссылок"
    End If

  • Ответ :
  • ThisWorkbook.UpdateLink Name:=ThisWorkbook.LinkSources
    With ThisWorkbook
         .UpdateLink Name:=.LinkSources
    End With
    Комментарий : Если текущая рабочая книга содержит "битые" ссылки, т.е. ссылки на удалённые файлы или книги, которые были перемещены/переименованы без использования Excel, то в этом случае, будет выведено стандартное диалоговое окно, позволяющее изменить ссылку. Если же Вы откажетесь от изменения связи или воспользуетесь этим советом, то в результате получите ошибку.
  • Ответ :

    Если Вам необходимо сделать так, чтобы во всех формулах текущей книги, ссылка на одну рабочую книгу была заменена ссылкой на другую книгу, то для решения такой задачи можно использовать метод ChangeLink об'екта Workbook
  • iOldFile = "C:\Мои документы\Книга1.xls"
    iNewFile = "C:\Мои документы\Книга2.xls"

    ThisWorkbook.ChangeLink iOldFile, iNewFile, xlExcelLinks
    Комментарий :
  • Если формулы в текущей книге не будут содержать ссылок на старую книгу, то возникнет ошибка 1004
  • Если укажите несуществующую новую книгу, то будет выведено стандартное диалоговое окно, позволяющее выбрать файл. Если Вы откажетесь от выбора или воспользуетесь этим советом, то ссылка на старую книгу будет заменена ссылкой на несуществующую книгу и, как следствие, все формулы, где произошла такая замена, вернут значение ошибки #ССЫЛКА!
  • Если же новая книга существует, но в ней не будет рабочего листа с именем, которое используется в формулах, то в этом случае, будет выведено диалоговое окно, позволяющее выбрать лист. Если Вы откажетесь от выбора или воспользуетесь этим советом, то возникнет ошибка 1004, а формулы вернут значение ошибки #ССЫЛКА!
  • Ответ :
  • Private Sub OpenExcelLinks()
        iExcelLinks = ThisWorkbook.LinkSources(xlExcelLinks)
        If Not IsArray(iExcelLinks) Then
           MsgBox "Текущая рабочая книга не содержит нужных ссылок", , ""
           Exit Sub
        End If
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
            ReDim iOpenWb(1 To .Workbooks.Count)
            For iCount& = 1 To .Workbooks.Count
                iOpenWb(iCount&) = .Workbooks(iCount&).FullName
            Next
            For Each iFileName In iExcelLinks
                On Error Resume Next
                If Dir(iFileName) <> "" Then
                   If .IsError(.Match(iFileName, iOpenWb, 0)) = True _
                   Then .Workbooks.Open FileName:=iFileName, UpdateLinks:=0
                End If
            Next
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    End Sub
    Private Sub OpenExcelLinks2()
        Dim iBook As Workbook, iOpenWb$(), iCount&
        Dim iExcelLinks As Variant, iFileName As Variant
        iExcelLinks = ThisWorkbook.LinkSources(xlExcelLinks)
        If IsEmpty(iExcelLinks) = True Then
           MsgBox "Текущая рабочая книга не содержит нужных ссылок", , ""
           Exit Sub
        End If
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
            ReDim iOpenWb(1 To .Workbooks.Count)
            For Each iBook In .Workbooks
                iCount = iCount + 1
                iOpenWb(iCount&) = iBook.FullName
            Next
            On Error Resume Next
            For Each iFileName In iExcelLinks            
                If Dir(iFileName) <> "" Then
                   If Not IsNumeric(.Match(iFileName, iOpenWb, 0)) _
                   Then ThisWorkbook.OpenLinks Name:=iFileName
                End If
            Next
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    End Sub

  • Ответ :

    Для того, чтобы программно найти "битые" внешние ссылки, точнее говоря, определить какие XLS файлы, которые связаны с текущей рабочей книгой, были удалены/перемещены/переименованы, можно использовать нижеопубликованный макрос.
  • Private Sub GetBadXLSLink() 'Microsoft Excel 97 (и старше)
        Const vbAtrr = vbHidden + vbReadOnly + vbArchive
        
        iExcelLinks = ThisWorkbook.LinkSources(xlExcelLinks)
        If IsArray(iExcelLinks) = True Then
           On Error Resume Next
           For Each iLink In iExcelLinks           
               If Dir(iLink, vbAtrr) = "" Then
                  MsgBox "Данный файл был удалён/перемещён/переименован" & _
                  vbCrLf & iLink, vbCritical, "Обнаружена битая ссылка !!!"
               End If
           Next
        Else
           MsgBox "Рабочая книга «" & ThisWorkbook.Name & _
           "» не содержит XLS внешних ссылок", vbInformation, ""
        End If
    End Sub
    Актуально для MS Excel XP

    Вариант II. В этой версии разработчики расширили возможности метода LinkInfo об'екта Workbook и теперь он позволяет получить более подробную информацию о внешней ссылки, т.е.
    Private Sub GetBadXLSLinkXP() 'Microsoft Excel XP (и старше)
        iExcelLinks = ThisWorkbook.LinkSources(xlExcelLinks)
        If IsArray(iExcelLinks) = True Then
           For iCount& = 1 To UBound(iExcelLinks)
               iLink = iExcelLinks(iCount&)
               If ThisWorkbook.LinkInfo(iLink, _
                  xlLinkInfoStatus) = xlLinkStatusMissingFile Then
                  MsgBox "Этот файл был удалён/перемещён/переименован" & _
                  vbCrLf & iLink, vbCritical, "Найдена битая ссылка !!!"
               End If
           Next
        Else
           MsgBox "Рабочая книга «" & ThisWorkbook.Name & _
           "» не содержит XLS внешних ссылок", vbInformation, ""
        End If
    End Sub
    Private Sub GetBadXLSLinkXP2() 'Microsoft Excel XP (и старше)
        iExcelLinks = ThisWorkbook.LinkSources(xlExcelLinks)
        If IsArray(iExcelLinks) = True Then
           For Each iLink In iExcelLinks
               If ThisWorkbook.LinkInfo(iLink, _
                  xlLinkInfoStatus) = xlLinkStatusMissingFile Then
                  MsgBox "Этот файл был удалён/перемещён/переименован" & _
                  vbCrLf & iLink, vbCritical, "Найдена битая ссылка !!!"
               End If
           Next
        Else
           MsgBox "Рабочая книга «" & ThisWorkbook.Name & _
           "» не содержит XLS внешних ссылок", vbInformation, ""
        End If
    End Sub

  • Ответ : Актуально для MS Excel XP (и старше)

    Для того, чтобы программно разорвать связь с другими рабочими книгами, т.е. заменить все внешние ссылки на значения, которые они возвращают, причём во всех листах текущей книги, можно использовать нижеопубликованный макрос.
  • Private Sub ReplaceExternalLinksOnValues() 'Microsoft Excel XP (и старше)
        iExcelLinks = ThisWorkbook.LinkSources(xlExcelLinks)
        
        If Not IsEmpty(iExcelLinks) Then
           For Each iLink In iExcelLinks
               ThisWorkbook.BreakLink iLink, xlExcelLinks
           Next
        Else
           MsgBox "Рабочая книга «" & ThisWorkbook.Name & _
           "» не содержит XLS внешних ссылок", vbInformation, ""
        End If
    End Sub
    Комментарий : Если рабочий лист и ячейка, содержащая внешнюю ссылку, защищены, то связь разорвана не будет, но и ошибка не возникнет.

    Актуально только для MS Excel 97, 2000
    Если же Вы являетесь обладателем 97 или 2000 версии, то осуществить подобную замену в ячейках всех рабочих листов, можно, например, так :
    Private Sub ReplaceExternalLinksOnValues97() 'Microsoft Excel 97, 2000
        Dim iList As Worksheet, iSource As Range, iCell As Range
        
        iExcelLinks = ThisWorkbook.LinkSources(xlExcelLinks)
        If IsEmpty(iExcelLinks) = True Then Exit Sub
        
        Application.ScreenUpdating = False
        Application.Calculation = xlManual
        
        For Each iLink In iExcelLinks
            iFileName$ = "[" & GetFileName(iLink) & "]*!"
    
            For Each iList In ThisWorkbook.Worksheets
                iList.Protect , , , , True
                If iList.FilterMode = True Then iList.ShowAllData
                   
                Set iSource = iList.UsedRange
                Set iCell = iSource.Find(iFileName$, , xlFormulas, xlPart)
                Do Until iCell Is Nothing
                   iCell = iCell 'iCell.Value
                   Set iCell = iSource.FindNext
                Loop
            Next
        Next
        
        Application.Calculation = xlAutomatic
        Application.ScreenUpdating = True
    End Sub
    
    Private Function GetFileName$(iLink)
        For iCount% = Len(iLink) To 1 Step -1
            If Mid(iLink, iCount%, 1) = "\" Then
               GetFileName$ = Mid(iLink, iCount% + 1)
               Exit Function
            End If
        Next
    End Function
    Иногда, поиск формул, содержащих вполне конкретные имена рабочих книг, можно заменить на поиск шаблона "=*[*]*!*"
    Private Sub ReplaceExternalLinksOnValues97v2() 'Microsoft Excel 97, 2000
        Dim iList As Worksheet, iSource As Range, iCell As Range
    
        Application.ScreenUpdating = False
        Application.Calculation = xlManual
    
        For Each iList In ThisWorkbook.Worksheets
            iList.Protect UserInterfaceOnly:=True
            If iList.FilterMode = True Then iList.ShowAllData
    
            Set iSource = iList.UsedRange
            Set iCell = iSource.Find("=*[*]*!*", , xlFormulas) '"=*[*.xls]*!*"
            Do Until iCell Is Nothing
               iCell = iCell 'iCell.Value
               Set iCell = iSource.FindNext
            Loop
        Next
    
        Application.Calculation = xlAutomatic
        Application.ScreenUpdating = True
    End Sub
    Комментарий : Если же в ячейках нет других формул(функций), кроме внешних ссылок, то в таком случае, можно просто заменить все формулы на их значения [FAQ]
  • Ответ :
  • If ThisWorkbook.Saved = True Then 'Workbooks(...)
       MsgBox "Изменений не было или они были сохранены"
    Else
       MsgBox "Изменения произошли"
    End If
    Комментарий : Изменением также считается пересчёт формул, даже если результат вычислений не отличается от предыдущих. Если Вам необходимо "отловить" более реальные изменения, то используйте следующий вариант, но не забывайте, что в этом случае должна быть открыта только одна рабочая книга.
    If Application.CommandBars.FindControl _
       (Id:=128).Enabled = False Then
       MsgBox "Изменений не было или они были сохранены"
    Else
       MsgBox "Изменения произошли"
    End If

  • Ответ :
  • Private Sub Find_Personal()
    With Application
         iPath$ = .StartupPath
         iFile$ = "Personal.xls"
         iFullName$ = iPath$ & .PathSeparator & iFile$
         If Dir(iFullName$, vbArchive + vbHidden + vbReadOnly) = "" Then
            MsgBox "Личная книга макросов " & iFile$ & vbNewLine & _
                   "- не была создана" & vbNewLine & _
                   "- была переименована, удалена" & vbNewLine & _
                   "- или же была перемещена ...", , ""
         Else
            MsgBox "Личная книга макросов находится :" & vbNewLine & iPath$, , ""
         End If
    End With
    End Sub
    Private Sub Find_Personal2()
        iPath$ = Application.StartupPath
        iFile$ = "Personal.xls"
        iFullName$ = iPath$ & "\" & iFile$
        MsgBox "Личная книга макросов " & iFile$ & _
        IIf(Dir(iFullName$, vbArchive + vbHidden + vbReadOnly) <> "", _
            " находится здесь - " & vbNewLine & iPath$, vbNewLine & _
            "- не была создана" & vbNewLine & _
            "- была переименована, удалена" & vbNewLine & _
            "- или же была перемещена ..."), , ""
    End Sub

  • Ответ :

    Для того, чтобы получить путь к текущему каталогу можно воспользоваться любым из двух вариантов. Обратите внимание на то, что функция CurDir() позволяет получить текущий путь для конкретного диска (см. вторую инструкцию)

    Вариант I.
  • iCurDir = CurDir
    iCurDir = CurDir("D") '"D:"
    Вариант II.
    iCurDir = [INFO("Directory")]
    iCurDir = Evaluate("INFO(""Directory"")")

  • Ответ :
  • iFile = ThisWorkbook.Name
    iFile = ActiveWorkbook.Name
  • В первом примере указано имя файла, в котором содержится выполняемый, в настоящий момент, код.
  • Во втором примере указано имя активного файла.

    Дополнение : Об'единив этот пример с предыдущим вопросом можно написать следующий код для получения "адреса" файла :
  • iFullName = iPath & "\" & iFile

    iFullName = iPath & Application.PathSeparator & iFile
    Примечание : Можно также воспользоваться стандартным "методом" :
    iFullName = ThisWorkbook.FullName
    iFullName = ActiveWorkbook.FullName

  • Ответ :

    Для того, чтобы после открытия xls файла, в заголовке окна книги появлялось полное имя книги, можно сохранить весь нижеприведённый код в стандартном модуле личной книги "Personal.xls" или любой другой книги, находящейся в стандартном или альтернативном каталоге автозагрузки.
  • Private Sub Auto_Open()
        Application.Caption = "Источник"
        Application.OnWindow = "SetFullNameInWBCaption"
    End Sub

    Private Sub SetFullNameInWBCaption()
        ActiveWindow.Caption = ActiveWorkbook.FullName
    End Sub
    Если же Вы используете команду Новое в меню Окно и хотите, чтобы полное имя книги также содержало и индекс, например "C:\Мои документы\Рога и копыта.xls:2" , то воспользуйтесь следующим кодом :
    Private Sub SetFullNameInWBCaption()
        Dim iWindow As Window, iFullName$
        iFullName = ActiveWorkbook.FullName
        If ActiveWorkbook.Windows.Count = 1 Then
           ActiveWorkbook.Windows(1).Caption = iFullName
        Else
           For Each iWindow In ActiveWorkbook.Windows
               iWindow.Caption = iFullName & ":" & iWindow.WindowNumber
           Next
        End If
    End Sub
    Актуально для MS Excel 97, 2000, XP
    К сожалению, первый вариант не сработает, если при активации(открытии) рабочей книги будет автоматически отображаться нестандартное диалоговое окно UserForm, причём в модальном режиме. Однако, если воспользоваться вторым кодом, который необходимо скопировать в модуль ThisWorkbook(ЭтаКнига) личной книги "Personal.xls" или любой другой книги, находящейся в стандартном или альтернативном каталоге автозагрузки, то получить полное имя файла, включая и WindowNumber, всё-таки можно, правда только после закрытия формы.
    Private WithEvents XLApp As Excel.Application

    Private Sub Workbook_Open()
        Set XLApp = Excel.Application: XLApp.Caption = "Источник"
    End Sub

    Private Sub XLApp_WindowActivate(ByVal Wb As Excel.Workbook, ByVal Wn As Excel.Window)
        If Wb.Windows.Count = 1 Then
           Wn.Caption = Wb.FullName
        Else
           For Each Wn In Wb.Windows
               Wn.Caption = Wb.FullName & ":" & Wn.WindowNumber
           Next
        End If
    End Sub
    Если же Вы пользуетесь командой Сохранить как ..., расположенной в меню Файл и хотите, чтобы полное имя файла отображалось также и в новой книге, то необходимо немного дополнить предыдущий вариант, т.е.
    Private WithEvents XLApp As Excel.Application

    Private Sub Workbook_Open()
        Set XLApp = Excel.Application: XLApp.Caption = "Источник"
    End Sub

    Private Sub XLApp_WindowActivate(ByVal Wb As Excel.Workbook, ByVal Wn As Excel.Window)
        SetText_WBCaption Wb ', Wn
    End Sub

    Private Sub XLApp_WorkbookBeforeSave(ByVal Wb As Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean)
        If SaveAsUI = True Then
           XLApp.OnTime DateAdd("s", 1, Now), Me.CodeName & ".SetText_WBCaption"
        End If
    End Sub

    Private Sub SetText_WBCaption(Optional Wb As Excel.Workbook)
        If Wb Is Nothing Then Set Wb = Excel.ActiveWorkbook

        If Wb.Windows.Count = 1 Then
           Wb.Windows(1).Caption = Wb.FullName
        Else
           Dim Wn As Excel.Window
           For Each Wn In Wb.Windows
               Wn.Caption = Wb.FullName & ":" & Wn.WindowNumber
           Next
        End If
    End Sub

  • Ответ :

    Для того, чтобы добавить ссылку на нужную рабочую книгу в папку "Избранное" достаточно воспользоваться методом AddToFavorites об'екта Workbook. Обратите внимание на то, что указанная книга обязательно должна быть сохранена, иначе, Вы получите ошибку.
  • ThisWorkbook.AddToFavorites
    ActiveWorkbook.AddToFavorites
    Workbooks("Имя_открытой_книги.xls").AddToFavorites

  • Ответ : Актуально для MS Excel 95, 97, 2000, XP
  • Private Sub Get_DocProperties()
        With ThisWorkbook
             iAuthor$ = .Author
             iComments$ = .Comments
             iKeywords$ = .Keywords
             iSubject$ = .Subject
             iTitle$ = .Title
        End With
    End Sub
    Private Sub Set_DocProperties()
        With ThisWorkbook
             If .ProtectStructure = True Or _
                .MultiUserEditing = True Then
                MsgBox "Свойства книги изменить нельзя", , ""
                Exit Sub
             End If
             .Author = "Microsoft"
             .Comments = "Вроде бы нужный отчёт, хотя ..."
             .Keywords = "Ключевые слова будут добавлены позже"
             .Subject = "Отчёт о количестве баранов"
             .Title = "Самое обычное название"
        End With
    End Sub
    Актуально для MS Excel 97, 2000, XP
    Private Sub Get_DocProperties97()
        With ThisWorkbook.BuiltinDocumentProperties
             iApplication$ = .Item("Application Name")
             iAuthor$ = .Item("Author")
             iCategory$ = .Item("Category")
             iComments$ = .Item("Comments")
             iCompany$ = .Item("Company")
             iCreation_Date$ = .Item("Creation Date")
             iHyperlink_Base$ = .Item("Hyperlink Base")
             iKeywords$ = .Item("Keywords")
             iLast_Author$ = .Item("Last Author")
             iLast_Print_Date$ = .Item("Last Print Date")
             iLast_Save_Time$ = .Item("Last Save Time")
             iManager$ = .Item("Manager")
             iRevision_Number$ = .Item("Revision Number")
             iSecurity$ = .Item("Security")
             iSubject$ = .Item("Subject")
             iTemplate$ = .Item("Template")
             iTitle$ = .Item("Title")
             'iTotal_Editing_Time$ = .Item("Total Editing Time")
        End With
    End Sub
    Комментарий : Обратите внимание на то, что если книга не была отправлена на печать и/или ещё не была сохранена, то попытка получить значение свойств "Last Print Date", "Last Save Time" приведёт к возникновению ошибки.
    Private Sub Set_DocProperties97()
        With ThisWorkbook.BuiltinDocumentProperties
             .Item("Author") = "Печёнкин"
             .Item("Category") = "Отправки"
             .Item("Comments") = "Без комментариев"
             .Item("Company") = "АОЗТ СибТранс"
             .Item("Keywords") = "груз;отправка;доставка"
             .Item("Last Author") = "XXX"
             .Item("Manager") = "Сусликов"
             .Item("Subject") = "Груз"
             .Item("Title") = "Счёт от " & Date$
             ' и т.д. и т.п.
        End With
    End Sub

  • Ответ : Актуально для MS Excel 97, 2000, XP
  • Private Sub Set_CustomProperties()
        With ThisWorkbook.CustomDocumentProperties
             .Add Name:="Счётчик", LinkToContent:=False, _
             Type:=msoPropertyTypeNumber, Value:=1234567890

             .Add Name:="Памятка", LinkToContent:=False, _
             Type:=msoPropertyTypeString, Value:="Текст"

             .Add Name:="Дата_изменения", LinkToContent:=False, _
             Type:=msoPropertyTypeDate, Value:=#4/22/2007#

             .Add Name:="Печать", LinkToContent:=False, _
             Type:=msoPropertyTypeBoolean, Value:=False

             .Add Name:="Связь_объект", LinkToContent:=True, _
             Type:=msoPropertyTypeFloat, LinkSource:="Имя_ячейки"
        End With
    End Sub
    Примечание :
  • Если в текущей рабочей книге уже есть пользовательские свойства с указанными именами, то в этом случае возникнет ошибка.
  • В последнем примере создаётся свойство, которое будет связано с именованной ячейкой "Имя_ячейки"
  • Увидеть созданные пользовательские свойства можно, если в меню Файл выбрать команду Свойства и в появившемся стандартном диалоговом окне выделить закладку Прочие.

    Для того, чтобы получить или изменить значение уже существующего пользовательского свойства, можно использовать его имя или индекс в семействе CustomDocumentProperties, например :
  • iCounter = ThisWorkbook.CustomDocumentProperties("Счётчик")
    iDateChange = ThisWorkbook.CustomDocumentProperties(3)
    ThisWorkbook.CustomDocumentProperties("Счётчик") = 0
    ThisWorkbook.CustomDocumentProperties(3) = Date

  • Ответ :

    Если Вам приходится открывать рабочие книги, которые создавались/редактировались людьми, которые предпочитают использовать стиль ссылок R1C1, то после работы с такими книгами, приходится возвращать привычные настройки [FAQ] Однако, если изменение нотации приходится производить довольно часто, то в этом случае, можно воспользоваться макросом, т.е. одним из двух представленных вариантов :

    Актуально для MS Excel 95, 97, 2000, XP
    Разместите весь нижеприведённый код в любом стандартном модуле личной книги макросов "Personal.xls" (или любой другой книги, которая расположена в "основном" или дополнительном каталоге автозагрузки)
  • Private Sub Auto_Open()
        Application.OnWindow = "ReferenceStyle"
    End Sub

    Private Sub ReferenceStyle()
        With Application
             If .ReferenceStyle = xlR1C1 Then .ReferenceStyle = xlA1
        End With
    End Sub
    Актуально для MS Excel 97, 2000, XP
    Разместите весь нижеприведённый код только в модуле ThisWorkbook(ЭтаКнига) личной книги макросов "Personal.xls" (или любой другой книги, которая расположена в "основном" или дополнительном каталоге автозагрузки)
    Private WithEvents XLApp As Excel.Application

    Private Sub Workbook_Open()
        Set XLApp = Excel.Application
    End Sub

    Private Sub XLApp_WorkbookActivate(ByVal Wb As Excel.Workbook)
        If XLApp.ReferenceStyle = xlR1C1 Then XLApp.ReferenceStyle = xlA1
    End Sub
    Комментарий :
  • Если изменение стиля ссылок, во время работы с рабочими книгами, не предвидится(предполагается), то событие XLApp_WorkbookActivate() можно заменить на событие XLApp_WorkbookOpen()
  • При желании можно обойтись и без проверки, но тогда изменение будет происходить при каждой активации, т.е. даже в тех случаях, когда стиль A1 уже установлен.
  • Ответ : Актуально для Windows 2000 & MS Excel 97 (или старше)

    Если Вам необходимо создавать ежедневный отчёт, включающий в себя время, имя пользователя, компьютера, папки (только открытие), книги, которая была открыта или создана, то разместите весь нижеприведённый код только в модуле ThisWorkbook(ЭтаКнига) личной книги макросов "Personal.xls" (или любой другой книги, которая расположена в "основном" или дополнительном каталоге автозагрузки)
  • Private WithEvents XLApp As Excel.Application
    
    Private Sub Workbook_Open()
        Set XLApp = Excel.Application
    End Sub
    
    Private Sub XLApp_NewWorkbook(ByVal Wb As Excel.Workbook)
        CreateLogFile Wb, "Создание"
    End Sub
    
    Private Sub XLApp_WorkbookOpen(ByVal Wb As Excel.Workbook)
        CreateLogFile Wb, "Открытие"
    End Sub
    
    Private Sub CreateLogFile(Wb As Workbook, LogEvent$)
        iLogFile$ = XLApp.Path & "\" & Date$ & ".txt"
        
        Open iLogFile$ For Append As #1
             Write #1, Time$, Environ("UserName"), _
             Environ("ComputerName"), Wb.Name, Wb.Path, LogEvent$
        Close #1
    End Sub
    Комментарий :
  • Если Вы используете Win9x/Me, то замените функцию Environ на соответствующие функции WinAPI [FAQ333], [FAQ335], [FAQ506] или WScript.Network [FAQ303], [FAQ334]
  • Папку, в которой будут накапливаться отчёты, можно изменить на более приемлемую.
    Воспроизведение любых опубликованных здесь материалов возможно только с письменного разрешения автора : Microsoft Excel 95, 97, 2000, XP

  • © 2004-2017 Климов П.Ю. Все права защищены. WebDesign & Error's Klimoff