Готовые макросы в vba excel, Миронов Глава Макросы 9
Скачать 1.35 Mb.
|
Запрет печати книгиSub Workbook_BeforePrint(Cancel As Boolean) ' Установка флага в True заставляет Exсel игнорировать команду _ отправки книги на печать Cancel = True End Sub Открытие книги (или текстовых файлов)Sub Test() Application.Workbooks.Open ("c:\file_03.txt") End Sub Открытие книги и добавление в ячейку А1 текстаDim Ex As New Excel.Application Ex.Workbooks.Open "Путь к Файлу" Ex.Visible = False 'В ячейку "A2" добавляем "Visual Basic" Ex.ActiveWorkbook.Sheets.Application.Range("A2") = "Visual Basic" Ex.ActiveWorkbook.Save Ex.ActiveWorkbook.Close Сколько книг открытоSub Test() MsgBox (Str(Application.Workbooks.Count)) End Sub Закрытие всех книгSub Test() Application.Workbooks.Item(1).Close ‘(expression.Close(SaveChanges, FileName, RouteWorkbook) End Sub Закрытие рабочей книги только при выполнении условияSub Workbook_BeforeClose(Cancel As Boolean) If Range("A1").Value <> "Можно закрывать" Then ' Условие закрытия не выполнено. Укажем Exсel игнорировать _ команду Cancel = True End If End Sub Сохранение рабочей книги с именем, представляющим собой текущую датуSub SaveAsDate() Dim strDate As String ' Получение текущей даты и представление ее в формате "ддммгг" strDate = Format(Now(), "ddmmyy") ' Сохранение книги в текущую папку под новым именем ActiveWorkbook.SaveAs ActiveWorkbook.Path & "\" & strDate End Sub Сохранена ли рабочая книгаFunction dhBookIsSaved() As Boolean ' Если путь файла рабочей книги не задан, то она _ не сохранена (ThisWorkbook.path равняется "") dhBookIsSaved = ThisWorkbook.path <> "" End Function Создать книгу с одним листомSub NewOneSheetBook() Workbooks.Add xlWBATWorksheet End Sub Создать книгуSub Test() Application.Workbooks.Add ("Êíèãà") End Sub Удаление ненужных именSub EraseNames() Dim nmName As Name Dim strMessage As String ' Проверка наличия в книге определенных имен If ThisWorkbook.Names.Count = 0 Then ' В книге нет определенных имен MsgBox "Имена не определены" Exit Sub End If ' Просмотр всей коллекции определенных имен и удаление тех, _ которые пользователю не нужны For Each nmName In ThisWorkbook.Names With nmName ' Спрашиваем пользователя о необходимости удалить _ найденное имя strMessage = "Удалить имя " & .Name & " ? " & vbCr & _ "относящееся к " & .RefersTo If MsgBox(strMessage, vbYesNo + vbQuestion) = vbYes Then ' Имя можно удалить .Delete End If End With Next End Sub Быстрое размножение рабочей книгиSub DuplicateBook() Dim avarFileNames As Variant ' Формирование массива из путей для копий книги avarFileNames = Array("C:\" & _ ActiveWorkbook.Name, "D:\" & ActiveWorkbook.Name) ' Сохранение книги ActiveWorkbook.SaveAs avarFileNames End Sub Сортировка листовSub SortSheets() Dim astrSheetNames() As String ' Массив для хранения имен листов Dim intSheetCount As Integer Dim i As Integer Dim objActiveSheet As Object ' Если нет активной рабочей книги - закрыть процедуру If ActiveWorkbook Is Nothing Then Exit Sub ' Проверка защищенности структуры рабочей книги If ActiveWorkbook.ProtectStructure Then ' Сортировка листов защищенной рабочей книги невозможна MsgBox "Структура книги " & ActiveWorkbook.Name & _ " защищена. Сортировка листов невозможна.", _ vbCritical Exit Sub End If ' Сохраняем ссылку на активный лист книги Set objActiveSheet = ActiveSheet ' Отключение сочетания клавиш Ctrl+Pause Break Application.EnableCancelKey = xlDisabled ' Отключение обновления экрана Application.ScreenUpdating = False intSheetCount = ActiveWorkbook.Sheets.Count ' Заполнение массива astrSheetNames именами листов книги ReDim astrSheetNames(1 To intSheetCount) For i = 1 To intSheetCount astrSheetNames(i) = ActiveWorkbook.Sheets(i).Name Next i ' Сортировка массива имен в порядке возрастания Call Sort(astrSheetNames) ' Перемещение листов книги For i = 1 To intSheetCount ActiveWorkbook.Sheets(astrSheetNames(i)).Move _ ActiveWorkbook.Sheets(i) Next i ' Переход на исходный рабочий лист objActiveSheet.Activate ' Включение обновления экрана Application.ScreenUpdating = True ' Включение сочетания клавиш Ctrl+Pause Break Application.EnableCancelKey = xlInterrupt End Sub Sub Sort(astrNames() As String) ' Сортировка массива строк по алфавиту (в порядке возрастания) Dim i As Integer, j As Integer Dim strBuffer As String Dim fBuffer As Boolean For i = LBound(astrNames) To UBound(astrNames) - 1 For j = i + 1 To UBound(astrNames) If astrNames(i) > astrNames(j) Then ' Меняем i-й и j-й элементы массива местами strBuffer = astrNames(i) astrNames(i) = astrNames(j) astrNames(j) = strBuffer End If Next j Next i End Sub |