Microsoft Excel:

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


Rambler's Top100


Counter CO.KZ


    [1] [2] [3]

  1. Как автоматически запустить макрос при открытии рабочей книги Лидер голосования 29.10.2005
  2. Как вручную открыть рабочую книгу без запуска макросов, в т.ч. Auto_Open, Workbook_Open ? 13.08.2006
  3. Как программно открыть рабочую книгу без автоматического запуска событий, в т.ч. Workbook_Open ? 13.08.2006
  4. Как при программном открытии рабочей книги - добавить имя книги в список последних открытых файлов ? 28.12.2006
  5. Как при открытии нужной рабочей книги, сделать так, чтобы имя определённого рабочего листа = текущей дате ? 29.03.2011
  6. Как не позволить сохранять рабочую книгу командой Сохранить как ? 24.09.2006
  7. Как перед закрытием рабочей книги выводить диалоговое окно с возможностью отмены закрытия ? 08.10.2006
  8. Как перед сохранением рабочей книги выводить диалоговое окно с подтвержением или отменой сохранения ? 08.10.2006
  9. Как перед печатью или просмотром выводить диалоговое окно с подтвержением или отменой печати ? 08.10.2006
  10. Как перед печатью/просмотром "сгенерировать" колонтитул содержащий данные нужных ячеек и отменить печать, если данные не соответствуют нужному типу ? 23.02.2007
  11. Как в рабочей книге заблокировать стандартные кнопки, команды и горячие клавиши, которые отвечают за копирование ? 23.02.2007
  12. Как удалить файл средствами VBA ? 2004
  13. Как переименовать, переместить, скопировать закрытый файл ? 06.01.2006
  14. Как программно изменить расширение закрытого файла ? 16.06.2010
  15. Как в строке, содержащей имя файла, заменить расширение файла ? 26.04.2008
  16. Как получить длинное имя файла/папки из короткого ? 24.01.2011
  17. Как извлечь имя файла из полного пути ? NEW 02.01.2016
  18. Как сохранить рабочую книгу сразу в несколько различных папок ? 09.06.2005
  19. Как сохранить копию активной рабочей книги с нужным именем (имя книги + дата и время сохранения) ? 28.12.2006
  20. Как программно установить пароль на открытие рабочей книги ? 04.03.2011
  21. Как определить существует или нет пароль на открытие книги ? 04.03.2011
  22. Как создать новую рабочую книгу на основе другой книги ? 20.08.2006
  23. Как создать рабочую книгу с одним рабочим листом ? 2004
  24. Как создать рабочую книгу с одним единственным листом диаграммы ? 09.03.2011
  25. Как создать рабочую книгу с нужным количеством рабочих листов ? 29.07.2006
  26. Как создать папку, каталог ? 24.11.2006
  27. Как переименовать папку, каталог ? 29.08.2007
  28. Как получить список вложенных подпапок ? 30.12.2007
  29. Как открыть в проводнике папку, где расположена рабочая книга ? 11.02.2007
  30. Как свернуть/развернуть окно рабочей книги ? 09.02.2008
  31. Как закрыть рабочую книгу без сохранения изменений ? 06.04.2007
  32. Как закрыть все рабочие книги без сохранения изменений ? 09.02.2008
  33. Как закрыть все рабочие книги, кроме текущей (или активной) ? NEW 18.09.2016
  34. Как в указанное время закрыть рабочую книгу с сохранением изменений ? 07.05.2007
  35. Как закрыть рабочую книгу, если она открывается после определённого времени, например, после окончания рабочего дня ? NEW 09.07.2016
    [1] [2] [3]


  • Ответ : Вопрос выбран посетителями Скачать пример

    Вариант I. Разместите в любом стандартном модуле :
  • Private Sub Auto_Open()
        Rem Здесь Ваш код
    End Sub ' (а)
    Private Sub Auto_Open()
        Имя_Вашего_макроса
    End Sub ' (б)
    Вариант II. Разместите в модуле ThisWorkbook(ЭтаКнига) :
    Private Sub Workbook_Open()
        Rem Здесь Ваш код
    End Sub ' (а)
    Private Sub Workbook_Open()
        Имя_Вашего_макроса
    End Sub ' (б)
    Совет : Макрос Auto_Open не вызывается автоматически, если открыть рабочую книгу программно. Однако его можно запустить принудительно, причём в случае отсутствия указанного макроса, ошибки не возникнет.
    iFullName = "C:\Temp\Test.xls"

    Workbooks.Open(FileName:=iFullName).RunAutoMacros Which:=xlAutoOpen
    iFullName = "C:\Temp\Test.xls"
    Workbooks.Open FileName:=iFullName
    ActiveWorkbook.RunAutoMacros xlAutoOpen
    Примечание : Не забудьте предварительно проверить наличие указанного файла [см. ниже]
  • Ответ : Актуально для MS Excel 97, 2000, XP
  • iFullName = "C:\Temp\Test.xls"

    Application.EnableEvents = False
    Workbooks.Open FileName:=iFullName
    Application.EnableEvents = True
    iFullName = "C:\Temp\Test.xls"

    With Application
         .EnableEvents = False
         .Workbooks.Open FileName:=iFullName
         .EnableEvents = True
    End With
    Используя этот совет мы можем блокировать выполнение и других событий, пример см. ниже
    iFullName = "C:\Temp\Test.xls"

    With Application
         .EnableEvents = False
         .ScreenUpdating = False
         With .Workbooks.Open(FileName:=iFullName)
              If Not .ProtectStructure Then
                 With .Worksheets.Add(After:=.Sheets(.Sheets.Count))
                      'Не будет выполняться событие Workbook_NewSheet
                      .Range("A1").Value = "Дата"
                      .Range("B1").Value = "Сумма"
                      .Range("C1").Value = "Оплата"
                      'Не будет выполняться событие Workbook_SheetChange
                 End With
              End If
              .Close saveChanges:=True
              'Не будет выполняться событие Workbook_BeforeClose
         End With
         .ScreenUpdating = True
         .EnableEvents = True
    End With
    Примечание : Не забудьте предварительно проверить наличие указанного файла [см. ниже]
  • Ответ :
  • Workbooks.Open FileName:="C:\Temp\Test.xls", AddToMru:=True
    Вариант II.
    Workbooks.Open FileName:="C:\Temp\Test.xls" Application.RecentFiles.Add Name:="C:\Temp\Test.xls"
    Application.RecentFiles.Add Workbooks.Open("C:\Temp\Test.xls").FullName
    Примечание : Не забудьте предварительно проверить наличие указанного файла [см. ниже]
  • Ответ : Актуально для MS Excel 97, 2000, XP Скачать пример

    Если Вы не хотите сохранять свою рабочую книгу выбором команды Сохранить как в меню Файл, то разместите этот код в модуле ThisWorkbook(ЭтаКнига) :
  • Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
        If SaveAsUI = True Then Cancel = True
    End Sub

  • Ответ : Актуально для MS Excel 97, 2000, XP Скачать пример

    Разместите в модуле ThisWorkbook(ЭтаКнига) :
  • Private Sub Workbook_BeforeClose(Cancel As Boolean)
        If MsgBox("Вы хотите закрыть рабочую книгу " & Me.Name & "?", vbYesNo) = vbYes Then
           Me.Save 'если необходимо сохранить изменения
        Else
           Cancel = True
        End If
    End Sub
    Если Вам необходимо создать точную копию стандартного сообщения, которое выводится перед закрытием рабочей книги, то :
    Private Sub Workbook_BeforeClose(Cancel As Boolean)
        Select Case MsgBox("Сохранить изменения в файле '" & Me.Name & "'?", vbYesNoCancel + vbQuestion)
            Case vbYes:    Me.Save
            Case vbNo:     Me.Saved = True
            Case vbCancel: Cancel = True
        End Select
    End Sub

  • Ответ : Актуально для MS Excel 97, 2000, XP Скачать пример

    Разместите в модуле ThisWorkbook(ЭтаКнига) :
  • Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
        If Me.Saved = False Then 'сообщ. не выводится, если не было изменений
           If MsgBox("Сохранить изменения в файле " & Me.Name & "?", vbYesNo) = vbNo Then
              Cancel = True
           End If
        End If
    End Sub

  • Ответ : Актуально для MS Excel 97, 2000, XP Скачать пример

    Разместите в модуле ThisWorkbook(ЭтаКнига) :
  • Private Sub Workbook_BeforePrint(Cancel As Boolean)
        If MsgBox("Вы хотите осуществить просмотр или печать ?", vbYesNo) = vbNo Then
           Cancel = True
        End If
    End Sub

  • Ответ :
  • Kill "Мусор.xls"
    Kill "C:\Мусор\" & "*.XLS"
    Kill "D:\Мусор\" & "*.TXT"
  • В первом примере показано удаление файла из текущей папки.
  • Во втором примере, удаление всех файлов с расширением .XLS из определённой папки на диске C:
  • В третьем примере, удаление всех файлов с расширением .TXT из определённой папки на диске D:

    Примечание : Если файл имеет атрибут только чтение и/или скрытый, то при использовании инструкции Kill Вы получите ошибку, которую можно избежать, если использовать :
  • SetAttr "C:\Архив\Продажи_2002.xls", vbNormal
    Kill "C:\Архив\Продажи_2002.xls"
    Удалённые файлы в корзину не помещаются, так что будьте внимательны.

  • Ответ :
  • iOldName = "C:\Temp\Test.txt"
    iNewName = "C:\Temp\Failure.txt"

    Name iOldName As iNewName
    iOldName = "C:\Archive\May_2005.xls"
    iNewName = "C:\Director\May_2005.xls"

    Name iOldName As iNewName
    iOldName = "C:\Archive\May_2005.xls"
    iNewName = "C:\Director\Report.xls"

    Name iOldName As iNewName
  • В первом примере показано переименование файла [.txt] в определённой папке на диске C:
  • Во втором примере, перемещение файла [.xls] из одной папки в другую на диске C:
  • В третьем примере, перемещение и переименование файла [.xls] из одной папки в другую на диске C:
  • iOldFile = "C:\Temp\Test.txt"
    iNewFile = "C:\Temp\ReTest.txt"

    FileCopy iOldFile, iNewFile
    iOldFile = "C:\Archive\May_2005.xls"
    iNewFile = "C:\Director\Report.xls"

    FileCopy iOldFile, iNewFile
    iOldFile = "C:\Archive\May_2005.xls"
    iNewFile = "C:\Director\May_2005.xls"

    FileCopy iOldFile, iNewFile
  • В первом примере показано копирование файла [.txt] в определённой папке на диске C:
  • Во втором примере, копирование файла [.xls] с "изменением" имени, из одной папки в другую на диске C:
  • В третьем примере, копирование файла [.xls] из одной папки в другую на диске C:

    Предполагается, что :
  • Указанные каталоги или папки существуют.
  • Исходный файл также существует и он закрыт.

    Примечание : Если файл с новым именем (iNewName) уже существует, то при использовании инструкции Name Вы получите ошибку.
  • Ответ :

    Для того, чтобы изменить расширение у существующего и закрытого файла можно также использовать инструкцию Name, например
  • iOldName = "C:\Temp\HTMLCode.txt"
    iNewName = "C:\Temp\HTMLCode.html"

    Name iOldName As iNewName
    Предполагается, что :
  • Указанные каталоги или папки существуют.
  • Исходный файл также существует и он закрыт.

    Примечание : Если файл с новым расширением (читайте именем - iNewName) уже существует, то при использовании инструкции Name Вы получите ошибку.

    Комментарий : Настоятельно не рекомендуется использовать следующий вариант, для изменения расширения, так как в результате Вы можете изменить и часть имени. Впрочем, подобного эффекта можно и избежать, если просто воспользоваться функцией VB_RenameExtension() [см. ниже] или аналогичной функцией WinAPI [FAQ]
  • iOldName = "C:\Archive.txt\HTMLCode.txt"

    iNewName = Application.Substitute(iOldName, ".txt", ".html") 'XL95, XL97, ...
    iNewName = Replace(iOldName, ".txt", ".html") 'XL2000, ...

    MsgBox iNewName, vbInformation, ""

  • Ответ :
  • Private Function VB_RenameExtension$(iFileName$, iNewExtension$)
        If iFileName$ Like "*.[A-z][A-z][A-z]" Then _
        Mid(iFileName$, Len(iFileName$) - 3, 4) = iNewExtension$
        
        VB_RenameExtension$ = iFileName$
    End Function
    
    Private Sub VB_ChangeExtension()
        iFileName$ = "C:\Мои документы\Годовой_отчёт.doc"
        
        iFileName$ = VB_RenameExtension(iFileName$, ".xls")
        MsgBox iFileName$, , "" ' исключительно для демонстрации
    End Sub
    Примечание : Данная функция не проверяет наличие файла и не меняет расширение у существующего файла. Она всего лишь изменяет строку, содержащую указанное имя файла, меняя старое расширение на новое. Если же строка не содержит расширения, то эта строка остаётся без изменений.

    Комментарий : Если же Вам необходимо, чтобы :
    - замена происходила в случае, если расширение файла содержит цифры, например, .mp3
    - в случае отсутствия расширения, в строке появлялось новое расширение
    - можно было осуществлять замену в том числе и .xlsx на .doc и наоборот, то используйте нижеопубликованный вариант :
    Private Function VB_RenameExtension$(iFileName$, iNewExtension$)
        iPosition& = InStr(Len(iFileName$) - 5, iFileName$, ".")
        If iPosition& > 0 Then
           VB_RenameExtension$ = _
           Left(iFileName$, iPosition& - 1) & iNewExtension$
        Else
           VB_RenameExtension$ = iFileName$ & iNewExtension$
        End If
    End Function

  • Ответ :
  • Private Function getLongPath$(iShortPath$)
        Dim iPathSeparator$, iPath$, iCount&, iArray
        
        iPathSeparator = Application.PathSeparator
        iArray = Split(iShortPath, iPathSeparator)
        getLongPath = iArray(0)
        For iCount = 1 To UBound(iArray)
            iPath = iArray(iCount)
            iPath = Dir(getLongPath & iPathSeparator & _
            iPath, vbDirectory + vbHidden + vbSystem) ' + ...
            If iPath = "" Then getLongPath = "": Exit Function
            getLongPath = getLongPath & iPathSeparator & iPath
        Next
    End Function
    Вариант I(б)
    Const iFileAttributes = vbDirectory + vbHidden + vbSystem '+ vbReadOnly
    
    Private Function getLongPath$(iShortPath$)
        Dim iPathSeparator$, iPath$, iCount&, iArray
      
        If Dir(iShortPath, iFileAttributes) <> "" Then
           iPathSeparator = Application.PathSeparator
           iArray = Split(iShortPath, iPathSeparator)
           getLongPath = iArray(0)
           For iCount = 1 To UBound(iArray)
               getLongPath = getLongPath & iPathSeparator & Dir( _
               getLongPath & iPathSeparator & iArray(iCount), iFileAttributes)
           Next
        End If
    End Function
    Private Sub CallFunction_getLongPath()
        Dim iLongPath$
        iLongPath = getLongPath("C:\DOCUME~1\АДМИНИ~1\LOCALS~1\TEMP")
        'iLongPath = getLongPath("C:\DOCUME~1\АДМИНИ~1\COOKIES\АДМИНИ~3.TXT")
        MsgBox iLongPath, , "" ' исключительно для демонстрации
    End Sub
    Примечание : Данная функция проверяет наличие файла/папки и возвращает полное имя, только при условии их наличия. В случае же отсутствия файла/папки функция возвратит пустую строку "" , но это легко исправить в соответствии с Вашими требованиями.
  • Ответ :

    Вариант I. Актуально для MS Excel 95, 97
  • Private Function getFileName$(iFullName$)
        For iCount% = Len(iFullName) To 1 Step -1
            If Mid(iFullName, iCount%, 1) = "\" Then
               getFileName = Mid(iFullName, iCount% + 1)
               Exit For
            End If
        Next
    End Function
    Вариант II. Актуально для MS Excel 2000(и старше)
    Private Function getFileName$(iFullName$)
        getFileName = Mid(iFullName, InStrRev(iFullName, "\") + 1)
    End Function
    Комментарий : Вышеопубликованные функции не проверяют наличие указанного файла и не вызывают ошибки в случае его отсутствия.

    Вариант III.

    Если же Вам необходимо извлечь имя файла из полного имени, только в случае наличия(существования) файла, то :
    Const iFileAttributes = vbHidden + vbSystem + vbReadOnly
    
    Private Function getFileName$(iFullName$)
        getFileName = Dir(iFullName, iFileAttributes)
    End Function

  • Ответ :
  • With ActiveWorkbook
        .SaveAs FileName:=Array("C:\Archive\" & .Name, _
        "D:\Temp\DocumentCopy\" & .Name)
    End With
    ActiveWorkbook.SaveAs FileName:=Array("C:\Archive\" & ActiveWorkbook.Name, "D:\Temp\DocumentCopy\" & ActiveWorkbook.Name)

  • Ответ :
    В зависимости от поставленной задачи, скопируйте нужный вариант и расположите его в любом стандартном модуле личной книги макросов "Personal.xls" Затем, используя этот [FAQ] создайте кнопку на панели инструментов. Нужная кнопка представляет команду Настраиваемая кнопка расположенную в категории Макросы. После чего, используя этот [FAQ] необходимо назначить созданной кнопке наш макрос.

    Вариант I. (Сохранение копии активной книги в папку, где находится копируемая книга. Если активная не была сохранена, то используется папка по умолчанию)
  • Private Sub ActiveWorkbook_SaveCopyAs()
        If Not ActiveWorkbook Is Nothing Then
           iFileName$ = ActiveWorkbook.Name
           iPath$ = ActiveWorkbook.Path '''
           iPathSeparator$ = Application.PathSeparator '"\"
           iSaveTime$ = Format(Now, "_dd/mm/yyyy_hh-mm-ss"".xls""")
           If iPath$ <> "" Then
              iFileName$ = Left(iFileName$, Len(iFileName$) - 4) & iSaveTime$
           Else
              iFileName$ = iFileName$ & iSaveTime$
              iPath$ = Application.DefaultFilePath
           End If
           ActiveWorkbook.SaveCopyAs _
           FileName:=iPath$ & iPathSeparator$ & iFileName$
        Else
           MsgBox "В настоящий момент нет активной книги", vbExclamation, ""
        End If
    End Sub
    Вариант II. (Сохранение копии активной книги в заранее указанную папку)
    Private Sub ActiveWorkbook_SaveCopyAs()
        iPath$ = "C:\Мои документы\Архив"
        'Укажите свою папку для сохранения копии активной книги

        If ActiveWorkbook Is Nothing Then
           MsgBox "В настоящий момент нет активной книги", vbExclamation, ""
           Exit Sub
        End If
        If Dir(iPath$, vbDirectory) = "" Then
           MsgBox "Указанная папка " & iPath$ & vbNewLine & _
           "была удалена, перемещена или переименована ", vbExclamation, ""
           Exit Sub
        End If

        iFileName$ = ActiveWorkbook.Name
        iPath$ = iPath$ & IIf(Right(iPath$, 1) = "\", "", "\")
        iSaveTime$ = Format(Now, "_dd/mm/yyyy_hh-mm-ss"".xls""")

        If ActiveWorkbook.Path <> "" Then
           iFileName$ = Left(iFileName$, Len(iFileName$) - 4) & iSaveTime$
        Else
           iFileName$ = iFileName$ & iSaveTime$
        End If

        ActiveWorkbook.SaveCopyAs FileName:=iPath$ & iFileName$
    End Sub

  • Ответ :

    Для того, чтобы программно установить пароль, который будет запрашиваться каждый раз, при попытке открыть книгу вручную, и который необходимо указывать, при открытии этой книги программно, можно использовать метод SaveAs об'екта Workbook. Далее приведён приведён пример установки пароля "ВашПароль" применительно к текущей книге.
  • Application.DisplayAlerts = False

    ThisWorkbook.SaveAs FileName:=ThisWorkbook.FullName, Password:="ВашПароль"

    Application.DisplayAlerts = True
    Application.DisplayAlerts = False
    With ThisWorkbook
         .SaveAs FileName:=.FullName, Password:="ВашПароль", WriteResPassword:=""
    End With
    Application.DisplayAlerts = True
    Совет : Если Вы хотите удалить уже имеющийся пароль, то просто используйте Password:="" , если же Вам необходимо узнать - установлен ли пароль на открытие или нет, то [см. ниже]

    Актуально для MS Excel XP
    В этой версии у об'екта Workbook появилось новое свойство Password, которое позволяет установить/изменить пароль на открытие рабочей книги, причём без сохранения файла. Обратите внимание на то, что данное свойство позволяет также узнать пароль, правда, он всегда скрывается за звёздочками (в количестве восьми штук), т.е. "********"
    ThisWorkbook.Password = "ВашПароль"

  • Ответ :
  • If ThisWorkbook.HasPassword = True Then
       MsgBox "Пароль на открытие этой книги, существует"
    Else
       MsgBox "Пароля не существует"
    End If
    If Not ActiveWorkbook.HasPassword Then
       MsgBox "Пароля не существует"
    Else
       MsgBox "Пароль на открытие активной книги, существует"
    End If

  • Ответ :
  • Workbooks.Add Template:="C:\Мои документы\Source.xls"
    Workbooks.Open FileName:="C:\Мои документы\Source.xlt"
    Примечание :
  • Второй вариант применим только для шаблонов, т.е. рабочих книг с расширением .xlt
  • Не забудьте предварительно проверить наличие указанного файла [см. ниже]
  • Ответ :
  • Workbooks.Add xlWBATWorksheet
    * - ответ дал А. Колесов
    ** - автор вопроса неизвестен



    08.01.2008 Следующий способ может оказаться полезен тем, кто работает с Visual Basic и предпочитает использовать позднее связывание.
    With CreateObject("Excel.Sheet")
         'Здесь Вы можете работать с новым об'ектом (рабочая книга)
    End With
    Dim iObject As Object 'Workbook
    Set iObject = CreateObject("Excel.Sheet")
    'Здесь Вы можете использовать об'ектную переменную

  • Ответ : Скачать пример

    Вариант I.
  • iOldCountList = Application.SheetsInNewWorkbook

    Application.SheetsInNewWorkbook = 7 'Максимум 255
    Workbooks.Add

    Application.SheetsInNewWorkbook = iOldCountList
    With Application
        iOldCountList = .SheetsInNewWorkbook

        .SheetsInNewWorkbook = 7 'Максимум 255
        With .Workbooks.Add
             Rem Здесь Вы получаете доступ к об'екту Workbook
        End With
        .SheetsInNewWorkbook = iOldCountList
    End With
    Вариант II.
    With Application
         .ScreenUpdating = False
         .Workbooks.Add(xlWBATWorksheet).Worksheets.Add Count:=11 ' Создание 12 рабочих листов
         .ScreenUpdating = True
    End With
    Вариант III.
    With Application
         .ScreenUpdating = False
         With .Workbooks.Add(xlWBATWorksheet)
              For iCount = 1 To 11 ' Создание 12 рабочих листов
                  .Worksheets.Add After:=.Worksheets(.Worksheets.Count)
              Next
         End With
         .ScreenUpdating = True
    End With
    Bonus : Небольшой пример создания новой рабочей книги с нужным количеством рабочих листов, с последующим их переименованием, и сохранением этой книги с выбранным именем.
    Option Compare Text

    Const iFileAttributes = vbArchive + vbHidden + vbReadOnly + vbSystem

    Private Sub CreateNewWorkbook()
    With Application
         iMonths = .GetCustomListContents(4)
         iOldCountList% = .SheetsInNewWorkbook
         iNewCountList% = UBound(iMonths) '=12

         Do
              iFullName = .GetSaveAsFilename( _
              InitialFileName:="NewWorkbook", FileFilter:="Excel Files (*.xls), *.xls", _
              Title:="Выберите нужную папку и введите имя книги, отличное от существующих")
         Loop While Not GetInfo(iFullName, .PathSeparator)

         .ScreenUpdating = False
         .SheetsInNewWorkbook = iNewCountList%

         With .Workbooks.Add
              For iCount% = 1 To iNewCountList%
                  .Worksheets(iCount%).Name = iMonths(iCount%)
              Next
              .Close saveChanges:=True, FileName:=iFullName
         End With

         .SheetsInNewWorkbook = iOldCountList%
         .ScreenUpdating = True
    End With
    End Sub

    Private Function GetInfo(iFullName, iPathSeparator$) As Boolean
    If iFullName <> False Then
        For iCount% = Len(iFullName) To 1 Step -1
            If Mid(iFullName, iCount%, 1) = iPathSeparator$ Then
               iFileName$ = Mid(iFullName, iCount% + 1)
               Exit For
            End If
        Next
        Dim iBook As Excel.Workbook
        For Each iBook In Workbooks
            If iBook.Name = iFileName$ Then Exit Function
        Next
        GetInfo = Dir(iFullName, iFileAttributes) <> iFileName$
    End If
    End Function

  • Ответ : Скачать пример
  • MkDir "C:\Мои документы\Архив\Документы\Счета"
    Примечание : Если папка уже существует или указан несуществующий путь "C:\Мои документы\Архив\Документы\", то при использовании инструкции MkDir Вы получите ошибку, которую можно избежать, если использовать :
    Private Sub My_MkDir(iPath$)
        iStart& = 1 '3
        iPathSeparator$ = Application.PathSeparator '"\"
        iPath$ = iPath$ & _
        IIf(Right(iPath$, 1) = iPathSeparator$, "", iPathSeparator$)
        Do
             iStart& = InStr(iStart& + 1, iPath$, iPathSeparator$)
             iTempPath$ = Mid(iPath$, 1, iStart&)
             If Dir(iTempPath$, vbDirectory) = "" Then _
                MkDir iTempPath$
        Loop While iStart& <> 0
    End Sub
    Пример вызова вышеопубликованной авторской процедуры :
    Private Sub Call_My_MkDir()
        My_MkDir "C:\Мои документы\Архив\Документы\Счета" 'Or
        'My_MkDir "C:\Мои документы\Архив\Документы\Счета\"
    End Sub
    Комментарий : Путь обязательно должен содержать существующий диск.
  • Ответ :
  • Private Sub GetSubFolders(iPath$)
        iPathSeparator$ = Application.PathSeparator '"\"
        iPath$ = iPath$ & _
        IIf(Right(iPath$, 1) = iPathSeparator$, "", iPathSeparator$)
        iObjName$ = Dir(iPath$, vbDirectory)
        Do While iObjName$ <> ""
           If iObjName$ <> "." And iObjName$ <> ".." Then
              If vbDirectory = (GetAttr(iPath$ & iObjName$) And vbDirectory) Then
                 iCount& = iCount& + 1
                 MsgBox iCount & ". " & iObjName$, , iPath$
              End If
           End If
           iObjName$ = Dir
        Loop
    End Sub
    Пример вызова процедуры GetSubFolders(), которая позволяет получить вложенные подпапки :
    Private Sub Call_Procedure()
        'GetSubFolders "C:\Мои документы"
        'GetSubFolders "C:\Мои документы\"
        GetSubFolders Environ("WinDir")
    End Sub
    Комментарий :
  • Путь обязательно должен содержать существующий диск.
  • Функция MsgBox и счётчик используются исключительно для демонстрации и, конечно же, могут быть заменены другими инструкциями.
  • Ответ :
  • iOldName = "C:\Мои документы\Excel_files"
    iNewName = "C:\Мои документы\Word_files"

    Name iOldName As iNewName
    Предполагается, что : папка, которую Вы планируете переименовать, существует.

    Примечание : Если папка с новым именем (iNewName) уже существует, то при использовании инструкции Name Вы получите ошибку, которую можно избежать, если предварительно проверить наличие "новой" папки [FAQ65]
  • Ответ : Актуально для MS Excel 97, 2000, XP
  • ThisWorkbook.FollowHyperlink Address:=ThisWorkbook.Path & "\"
    With ThisWorkbook
         .FollowHyperlink Address:=.Path & "\"
    End With
    Если необходимо не только открыть в проводнике папку, где расположена рабочая книга, но и выделить эту книгу, то Вы можете использовать следующий вариант :
    Shell "Explorer.exe /select,""" & ThisWorkbook.FullName & """", vbMaximizedFocus 'vbNormalFocus
    Более подробную информацию о параметрах командной строки, используемых при запуске проводника Windows, можно найти в статье, опубликованной на официальном сайте Microsoft
  • Ответ :

    Для того, чтобы свернуть/развернуть окно активной рабочей книги (конечно, если таковая имеется), можно использовать следующий вариант :
  • ActiveWindow.WindowState = xlMinimized
    ActiveWindow.WindowState = xlMaximized
    Если же существует вероятность того, что в момент выполнения этих инструкций, окна всех книг будут скрыты [FAQ] или их не будет вообще, то :
    If Not ActiveWindow Is Nothing Then _
    ActiveWindow.WindowState = xlMinimized 'xlMaximized
    Для того, чтобы свернуть/развернуть окно конкретной рабочей книги, можно использовать следующий вариант (не забывая при этом, что указанная рабочая книга обязательно должна быть открыта и её окно не должно быть скрыто)
    Workbooks("Имя_Книги.xls").Windows(1).WindowState = xlMinimized
    Если одна книга может иметь несколько окон [FAQ], то :
    Dim iWindow As Window
    For Each iWindow In ThisWorkbook.Windows
        If iWindow.Visible = True Then _
        iWindow.WindowState = xlMinimized
    Next

  • Ответ :

    Вариант I.
  • ThisWorkbook.Close saveChanges:=False
    Вариант II.
    ThisWorkbook.Saved = True
    ThisWorkbook.Close
    Комментарий : При закрытии рабочей книги программно - будет вызвано событие Workbook_BeforeClose, что может привести к сохранению всех имеющихся несохранённых изменений, например, если в этом макросе(событии) использован метод Save. Поэтому, я рекомендую воспользоваться этим [FAQ157] и недопустить вызова и выполнения этого события.
  • Ответ :

    Вариант I.
  • Application.DisplayAlerts = False: Workbooks.Close
    With Application
         '.EnableEvents = False
         .DisplayAlerts = False     
         .Workbooks.Close
    End With
    Вариант II.
    ExecuteExcel4Macro "CLOSE.ALL()"
    With Application
         '.EnableEvents = False
         .ExecuteExcel4Macro "CLOSE.ALL()"
    End With
    Вариант III.
    With Application
         .ScreenUpdating = False
         '.EnableEvents = False
         Dim iBook As Workbook
         For Each iBook In .Workbooks
             iBook.Close saveChanges:=False
             'iBook.Saved = True: iBook.Close
         Next
    End With
    Примечание : Если в открытых рабочих книгах есть событие Workbook_BeforeClose, которое выполняется, в т.ч. и при программном закрытии книги, и может помешать закрытию книги, то тогда необходимо блокировать выполнение этого события.

    Комментарий : Если после закрытия книг, Вы не собираетесь использовать Excel, то в этом случае, можно закрыть Excel не сохраняя изменений в открытых рабочих книгах [FAQ]
  • Ответ :

    Вариант I. Для того, чтобы закрыть все открытые рабочие книги (с сохранением всех изменений), за исключением текущей, можно использовать такой способ :
  • Private Sub CloseAllWorkbooks_ExceptThisWorkbook()
        Dim iBook As Workbook
        For Each iBook In Workbooks
            If Not ThisWorkbook Is iBook Then
               iBook.Close saveChanges:=True
            End If
        Next
    End Sub
    Вариант II. Если же необходимо закрыть все открытые книги, за исключением активной рабочей книги, то в этом случае, также можно использовать предыдущий вариант, только необходимо заменить ThisWorkbook на ActiveWorkbook. Но можно воспользоваться и альтернативным способом и просто сравнивать имена книг, т.е.
    Private Sub CloseAllWorkbooks_ExceptActiveWorkbook()
        Dim iBook As Workbook
        For Each iBook In Workbooks
            If ActiveWorkbook.Name <> iBook.Name Then
               iBook.Close saveChanges:=True
            End If
        Next
    End Sub
    Примечание :
  • Если в открытых рабочих книгах есть событие Workbook_BeforeClose, которое выполняется, в т.ч. и при программном закрытии книги, и может помешать закрытию книги, то тогда необходимо блокировать выполнение этого события.
  • Если необходимо закрыть книги без сохранения изменений, то замените True на False
  • Ответ :

    Для того, чтобы автоматически закрыть нужную рабочую книгу в указанное время, скопируйте весь нижеприведённый код в любой стандартный модуль этой книги.
  • Const iTime = #6:00:00 PM# '18:00:00

    Private Sub Auto_Open()
        Application.OnTime EarliestTime:=iTime, Procedure:="Workbook_Close"
    End Sub

    Private Sub Workbook_Close()
        ThisWorkbook.Close saveChanges:=True
    End Sub

    Private Sub Auto_Close()
        If Time < iTime Then
           Application.OnTime EarliestTime:=iTime, _
           Procedure:="Workbook_Close", Schedule:=False
        End If
    End Sub
    Комментарий : В данном примере предполагается, что нужная рабочая книга будет открываться вручную, естественно с разрешением макросов. Это не является обязательным условием, т.к. в версии MS Excel 97 и старше можно использовать события рабочей книги Workbook_Open, Workbook_BeforeClose, которые выполняются при программном открытии/закрытии книги. Однако, не стоит всецело на них полагаться, т.к. рабочую книгу можно открыть программно блокировав при этом выполнение всех событий.
  • Ответ : Актуально для MS Excel 97-2003

    Для того, чтобы закрыть нужную рабочую книгу, если она открывается после определённого времени, например, после окончания рабочего дня, т.е. 18:00 , скопируйте весь нижеприведённый код в модуль ThisWorkbook(ЭтаКнига) :
  • Private Sub Workbook_Open()
        If Time > #6:00:00 PM# Then
           MsgBox "Рабочий день закончился, пора домой"
           Me.Close saveChanges:=False
        End If
    End Sub
    Если же необходимо указать другое время, но просто имейте ввиду, что PM означает после полудня, т.е. после 12:00 часов дня, а AM, соответственно, до полудня. Впрочем, если Вы не хотите запоминать такое время_исчисление, то в следующем варианте, можно использовать более привычный способ.
    Private Sub Workbook_Open()
        If Time > TimeValue("18:00:00") Then 'CDate("18:00:00")
           MsgBox "Рабочий день закончился, пора домой"
           Me.Close saveChanges:=False
        End If
    End Sub
    Комментарий :
  • Для полной автоматизации процесса закрытия, т.е. чтобы книга автоматически закрывалась в т.ч. и после программного открытия, следует закомментировать/удалить строку с VB(A) функцией MsgBox.
  • В версии MS Excel 95, для решения поставленной задачи, придётся использовать макрос Auto_Open, который, правда, не выполняется при программном открытии книги.
    Воспроизведение любых опубликованных здесь материалов возможно только с письменного разрешения автора : Microsoft Excel 95, 97, 2000, XP

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