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. Как извлечь имя файла из полного пути ? 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. Как закрыть все рабочие книги, кроме текущей (или активной) ? 18.09.2016
  34. Как в указанное время закрыть рабочую книгу с сохранением изменений ? 07.05.2007
  35. Как закрыть рабочую книгу, если она открывается после определённого времени, например, после окончания рабочего дня ? 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-2018 Климов П.Ю. Все права защищены. WebDesign & Error's Klimoff