Чат kullun
kullun (off) Хозяин
6 июня 2018, 23:01
Создание содержания в форме списка гиперссылок
Sub CreateTOC()
Dim i As Integer
Sheets.Add Before:=Sheets(1)
For i = 2 To Worksheets.Count
ActiveSheet.Hyperlinks.Add _
Anchor:=Cells(i, 1), _
A d d r e s s _
SubAddress: = "'" & Worksheets( 1 ).Name & "'!A1", _
TextToDisplay:=Worksheets(i).Name
Next i
End Sub
-----
kullun (off) Хозяин
6 июня 2018, 22:32
Частичное сокрытие элементов рабочего листа
В примере из этого раздела скрываются все строки и столбцы рабочего листа за исклю-
чением тех из них, которые находятся в текущем выделенном диапазоне.
Sub HideRowsAndColumns()
Dim rowl As Long, row2 As Long
Dim coll As Long, col2 As Long
If TypeName(Selection) <> "Range" Then Exit Sub
' Если скрыт последний столбец или строка, отобразить все и выйти
If Rows(Rows.Count).EntireRow.Hidden Or _
Columns(Columns.Count).EntireColumn.Hidden Then
Cells.EntireColumn.Hidden = False
Cells.EntireRow.Hidden = False
Exit Sub
End If
rowl = Selection.Rows(1).Row
row2 = rowl + Selection.Rows.Count - 1
coll = Selection.Columns(1).Columncol2 = coll + _
Selection.Columns.Count - 1
Application.ScreenUpdating = False
On Error Resume Next
' Скрыть строки
Range(Cells(1, 1), Cells(rowl - 1, 1)).EntireRow.Hidden = True
Range(Cells(row2 +1, 1), Cells(Rows.Count, _
1)).EntireRow.Hidden = True
' Скрыть столбцы
Range(Cells(1, 1), Cells(1, coll - 1)).EntireColumn.Hidden = _
True
Range(Cells(1, col2 + 1), Cells(l, Columns. _
Count)).EntireColumn.Hidden = True
End Sub
-----
kullun (off) Хозяин
6 июня 2018, 22:16
Управление рабочими книгами и листами
Следующая процедура циклически просматривает все рабочие книги в коллекции
Workbooks и сохраняет каждый файл, который сохранялся ранее.
Public Sub SaveAllWorkbooks()
Dim Book As Workbook
For Each Book In Workbooks
If Book.Path <> "" Then Book.Save
Next Book
End Sub
Обратите внимание на то, как используется свойство Path. Если для какой-либо рабо-
чей книги свойство Path не задано, значит, файл еще не сохранялся (это новая рабочая
книга). Данная процедура игнорирует такие рабочие книги и сохраняет только те из них,
свойство Path которых имеет ненулевое значение.
В улучшенном варианте процедуры проверяется свойство Saved. Это свойство прини-
мает значение True, если книга не изменялась с момента последнего сохранения. Благодаря
этому процедура SaveAllWorkbooks2 не сохраняет файлы, которые не нужно сохранять.
Public Sub SaveAllWorkbooks2()
Dim Book As Workbook
For Each Book In Workbooks
If Book.Path <> "" Then
If Book.Saved <> True Then
Book.Save
End If
End If
Next Book
End Sub
Сохранение и закрытие всех рабочих книг
Следующая процедура циклически просматривает коллекцию Workbooks. При этом
она сохраняет и закрывает все рабочие книги.
Sub CloseAllWorkbooks()
Dim Book As Workbook
For Each Book In Workbooks
If Book.Name <> ThisWorkbook.Name Then
Book.Close savechanges:=True
End If
Next Book
ThisWorkbook.Close savechanges:=True
End Sub
Sub CloseAllWorkbooks()
Dim Book As Workbook
For Each Book In Workbooks
If Book.Name <> ThisWorkbook.Name Then
Book.Close savechanges:=True
End If
Next Book
ThisWorkbook.Close savechanges:=True
End Sub
Обратите внимание на то, что процедура использует оператор If, чтобы определить,
содержит ли данная рабочая книга текущий выполняемый код. Это необходимо, так как
при закрытии рабочей книги, содержащей процедуру, программа автоматически завер-
шает свое выполнение, причем остальные рабочие книги не будут сохранены и закрыты.
-----
kullun (off) Хозяин
6 июня 2018, 21:57
Выбор ячеек по значению
Sub SelectByValue()
Dim Cell As Ob]ect
Dim FoundCells As Range
Dim WorkRange As Range
If TypeName(Selection) <> "Range" Then Exit Sub
' Проверить все или выделенное?
If Selection.CountLarge = 1 Then
Set WorkRange = ActiveSheet.UsedRange
Else
Set WorkRange = Application.Intersect(Selection, _
ActiveSheet.UsedRange)
End If
' Ограничение поиска только числовыми ячейками
On Error Resume Next
Set WorkRange = WorkRange.SpecialCells(xlConstants, xlNumbers)
If WorkRange Is Nothing Then Exit Sub
On Error GoTo 0
* Просмотр каждой ячейки, добавление в диапазон FoundCells ячеек,
' удовлетворяющих заданным условиям
For Each Cell In WorkRange
If Cell.Value < 0 Then
If FoundCells Is Nothing Then
Set FoundCells = Cell
Else
Set FoundCells = Union(FoundCells, Cell)
End If
End If
Next Cell
' Отображение сообщения либо выделение ячеек
If FoundCells Is Nothing Then
MsgBox "He найдены ячейки, соответствующие заданным _
условиям."
Else
FoundCells.Select
MsgBox "Выделено " & FoundCells.Count & " ячеек."
End If
End Sub
Уточнение результатов
поиска в диапазоне производится с помощью метода S pecialC ells, причем создается
объект Range, который содержит только числовые константы.
Код в цикле For-Next проверяет значение ячейки. Если оно соответствует критерию
(меньше 0), ячейка добавляется в объект FoundCells Range с помощью метода Union.
Обратите внимание на то, что для первой ячейки метод Union неприменим. Если диапа-
зон FoundCells не содержит ячеек, попытка применения метода Union приведет к появ-
лению ошибки. Таким образом код проверяет, не будет ли значение объекта FoundCells
равно Nothing.
-----
kullun (off) Хозяин
6 июня 2018, 19:07
Перенос диапазона в массив Variant
В показанном ниже примере диапазон ячеек переносится в двухмерный массив Variant.
Затем в окнах сообщений отображаются границы обеих размерностей массива Variant.
Sub RangeToVariant()
Dim x As Variant
x = Range("A1:L600").Value
MsgBox UBound(x, 1)
MsgBox UBound(x, 2)
End Sub
=======================================================
В следующем примере диапазон считывается в массив Variant, выполняется простая
операция умножения над каждым элементом массива и массив Variant перемещается
обратно в диапазон.
Sub RangeToVariant2()
Dim х As Variant
Dim r As Long, c As Integer
' Чтение данных в массив variant
х = Range("data").Value
' Просмотр массива
For r = 1 To UBound(x, 1)
For с = 1 To UBound(x, 2)
' Умножение на 2
x (г, с) = х (г, с) * 2
Next с
Next r
' Передача переменной типа Variant обратно на лист
Range("data") = х
End Sub
-----
kullun (off) Хозяин
6 июня 2018, 18:55
Более быстрый способ записи в диапазон
Sub LoopFillRange ()
' Заполнение диапазона в цикле по ячейкам
Dim CellsDown As Long, CellsAcross As Integer
Dim CurrRow As Long, CurrCol As Integer
Dim StartTime As Double
Dim CurrVal As Long
' Получение размеров
CellsDown = InputBox("Сколько ячеек по вертикали?")
If CellsDown = 0 Then Exit Sub
CellsAcross = InputBox("Сколько ячеек по горизонтали?")
If CellsAcross = 0 Then Exit Sub
' Запись момента начала
StartTime = Timer
' Просмотр ячеек и вставка значений
CurrVal = 1
Application.ScreenUpdating = False
For CurrRow = 1 To CellsDown
For CurrCol = 1 To CellsAcross
ActiveCell.Offset(CurrRow - 1, _
CurrCol - 1).Value = CurrVal
CurrVal = CurrVal + 1
Next CurrCol
Next CurrRow
' Отображение времени выполнения операции
Application.ScreenUpdating = True
MsgBox Format(Timer - StartTime, "00.00") & " секунд"
End Sub
===============================================
Следующий пример демонстрирует наилучший способ получения того же результата.
Программа вставляет значения в массив и использует всего один оператор для переноса
содержимого массива в диапазон.
Sub ArrayFillRange()
' Заполнение диапазона путем переноса массива
Dim CellsDown As Long, CellsAcross As Integer
Dim i As Long, j As Integer
Dim StartTime As Double
Dim TempArrayO As Long
Dim TheRange As Range
Dim CurrVal As Long
' Получение размеров
CellsDown = InputBox("Сколько ячеек в высоту?")
If CellsDown = 0 Then Exit Sub
CellsAcross = InputBox("Сколько ячеек в ширину?")
If CellsAcross = 0 Then Exit Sub
' Запись момента начала
StartTime = Timer
' Изменение размера временного массива
ReDim TempArray(l То CellsDown, 1 То CellsAcross)
' Определение диапазона на рабочем листе
Set TheRange = ActiveCell.Range(Cells(1, 1), _
Cells(CellsDown, CellsAcross))
' Заполнение временного массива
CurrVal = 0
Application.ScreenUpdating = False
For l = 1 To CellsDown
For ] = 1 To CellsAcross
TempArrayU, ]) = CurrVal + 1
CurrVal = CurrVal + 1
Next j
Next 1
' Перемещение временного массива в рабочую книгу
TheRange.Value = TempArray
' Отображение времени вычислений
Application.Screenupdating = True
MsgBox Format(Timer - StartTime, "00.00") & " секунд"
End Sub
Например, в моей системе на заполнение массива размером 1000x250 ячеек (250 тысяч
ячеек) методом цикла уходит 27 с. Метод переноса массива потребовал только 0,2 с для по-
лучения тех же самых результатов — примерно в 100 раз быстрее! Мораль? Если необходи-
мо переносить большие объемы данных на лист Excel, по возможности избегайте циклов.
-----
kullun (off) Хозяин
6 июня 2018, 18:43
Чтение и запись диапазонов
Sub WriteReadRange()
Dim MyArray()
Dim Timel As Double
Dim NumElements As Long, 1 As Long
Dim WnteTime As String, ReadTime As String
Dim Msg As String
NumElements = 250000
ReDim MyArray(1 To NumElements)
' Заполнение массива
For l = 1 To NumElements
MyArray(i) = 1
Next i
' Запись массива в диапазон
Timel = Timer
For i = 1 To NumElements
Cells(i, 1) = MyArray(i)
Next i
WriteTime = Format(Timer - Timel, "00:00")
' Считывание диапазона в массив
Timel = Timer
For i = 1 To NumElements
MyArray(i) = Cells(i, 1)
Next l
ReadTime = Format(Timer - Timel, "00:00")
' Отображение результатов
Msg = "Запись: " & WriteTime
Msg = Msg & vbCrLf
Msg = Msg & "Чтение: " & ReadTime
MsgBox Msg, vbOKOnly, NumElements & " элементов"
End Sub
-----
kullun (off) Хозяин
6 июня 2018, 18:34
Идентификация типа данных ячейки
В состав Excel входит ряд встроенных функций, которые могут помочь определить тип
данных, содержащихся в ячейке. Это функции ЕНЕТЕКСТ (ISTEXT), ЕЛОГИЧ (ISLOGICAL)
и Е ОШИБКА (ISERROR). Кроме того, VBA поддерживает функции IsEmpty, Is Date
и IsNumeric.
Ниже описана функция CellType, которая принимает аргумент-диапазон и возвра-
щает строку (Пусто, Текст, Булево выражение, Ошибка, Дата, Время или Значение),
описывающую тип данных левой верхней ячейки этого диапазона. Такую функцию можно
использовать в формуле рабочего листа или вызвать из другой процедуры VBA.
Function CellType(Rng)
' Возвращает тип левой верхней
' ячейки в диапазоне
Dim TheCell As Range
Set TheCell = Rng.Range ГА1”)
Select Case True
Case IsEmpty(TheCell)
CellType = ’’Пусто”
Case Application.IsText(TheCell)
CellType = "Текст"
Case Application.IsLogical(TheCell)
CellType = "Булево выражение"
Case Application.IsErr(TheCell)
CellType = "Ошибка"
Case IsDate(TheCell)
CellType = "Дата"
Case InStr(l, TheCell .Text, ’’:’’) о 0
CellType = "Время"
Case IsNumeric(TheCell)
CellType = "Значение"
End Select
End Function
Set TheCell = Rng.Range (А1”)
Функция CellType
получает аргумент-диапазон произвольного размера, но этот оператор указывает, что
функция оперирует только левой верхней ячейкой диапазона (представленной перемен-
ной TheCell)
-----
kullun (off) Хозяин
6 июня 2018, 18:26
Определение диапазона, находящегося в другом диапазоне
Функция InRange, код которой приводится ниже, имеет два аргумента, оба — объек-
ты Range. Функция возвращает значение True (Истина), если первый диапазон содержит-
ся во втором. Данная функция может применяться в формулах рабочего листа, но лучше
вызывать ее из другой процедуры.
Function InRange(rngl, rng2) As Boolean
' Возвращает True, если диапазон rngl входит в диапазон rng2
On Error GoTo ErrHandler
If Union(rngl, rng2).Address = rng2.Address Then
InRange = True
Exit Function
End If
ErrHandler:
InRange = False
End Function
Метод Union объекта Applicatio n возвращает объект Range, представляющий
объединение двух объектов Range. Объединение включает ячейки, относящиеся к обоим
диапазонам. Если адрес объединения двух диапазонов совпадает с адресом второго диа-
пазона, значит, первый диапазон содержится во втором.
-----
kullun (off) Хозяин
6 июня 2018, 18:17
Sub DupeRows()
Dim cell As Range
' В первой ячейке указано количество билетов
Set cell = Range ("В2")
Do While Not IsEmpty(cell)
If cell > 1 Then
Range(cell.Offset(1, 0), cell.Offset(cell.Value - 1, _
0) ).EntireRow.Insert
Range(cell, cell.Offset(cell.Value - 1, _
1) ).EntireRow.FillDown
End If
Set cell = cell.Offset(cell.Value, 0)
Loop
End Sub
-----
стр. Пред. 1,2,3 ... 6,7,8 ... 12,13,14 След.
0.039 сек
SQL: 3