Эмиссия газов от очистных сооружений канализации: В последние годы внимание мирового сообщества сосредоточено на экологических проблемах...
Биохимия спиртового брожения: Основу технологии получения пива составляет спиртовое брожение, - при котором сахар превращается...
Топ:
Установка замедленного коксования: Чем выше температура и ниже давление, тем место разрыва углеродной цепи всё больше смещается к её концу и значительно возрастает...
Методика измерений сопротивления растеканию тока анодного заземления: Анодный заземлитель (анод) – проводник, погруженный в электролитическую среду (грунт, раствор электролита) и подключенный к положительному...
Генеалогическое древо Султанов Османской империи: Османские правители, вначале, будучи еще бейлербеями Анатолии, женились на дочерях византийских императоров...
Интересное:
Финансовый рынок и его значение в управлении денежными потоками на современном этапе: любому предприятию для расширения производства и увеличения прибыли нужны...
Инженерная защита территорий, зданий и сооружений от опасных геологических процессов: Изучение оползневых явлений, оценка устойчивости склонов и проектирование противооползневых сооружений — актуальнейшие задачи, стоящие перед отечественными...
Национальное богатство страны и его составляющие: для оценки элементов национального богатства используются...
Дисциплины:
2021-10-05 | 44 |
5.00
из
|
Заказать работу |
|
|
Function Two2One(Text As String) As String
Dim Polki, i As Byte, tmp As String
Application.Volatile
Polki = Split(Text, "@")
For i = 1 To UBound(Polki)
If InStr(1, Polki(i), ":") > 0 Then
If Polki(i) <> Polki(i - 1) Then tmp = tmp & "@" & Polki(i)
Else: tmp = tmp & "@" & Polki(i)
End If
Next
Two2One = Polki(0) & tmp
End Function
Выделение диапазона над текущей ячейкой
Sub SelectCellRange()
Dim strSelTop As String, strSelBottom As String
' Получение адресов нижней и верхней ячеек диапазона для выделения
strSelBottom = ActiveCell.Address
strSelTop = Cells(1, ActiveCell.Column).Address
' Выделяем все ячейки выше текущей (вместе с текущей ячейкой)
Range(strSelTop & ":" & strSelBottom).Select
End Sub
Выделение диапазона над текущей ячейкой_2
Sub SelectColumnData()
' что делать при ошибке
On Error GoTo errors
' нижний адрес
Dim a1 As String
' верхний адрес
Dim a2 As String
' диапазое
Dim ran As Range
' если не верхнея ячейка
If (ActiveCell.Row <> 1) Then
' пойти вверх
ActiveCell.Offset(-1, 0).Select
' взять адрес ячейки
a1 = ActiveCell.Address
' будем подниматься
For x = 1 To (ActiveCell.Row - 1)
' на одну вверх
ActiveCell.Offset(-1, 0).Select
' если не число выход
If IsNumeric(ActiveCell.Value) <> True Then
' на одну вниз
ActiveCell.Offset(1, 0).Select
' выход
GoTo nexts
End If
' если пустая
If IsEmpty(ActiveCell.Value) = True Then
' на одну вниз
ActiveCell.Offset(1, 0).Select
' выход
GoTo nexts
End If
Next x
nexts:
' получаем адрес вырехней
a2 = ActiveCell.Address
' строим диапазон
Set ran = Range(a1 + ":" + a2)
' выбеляем
ran.Select
End If
' выходим из процедуры
Exit Sub
' ошибка зовем на помощь
errors:
MsgBox "Ошибка сообщите разработчику"
End Sub
Выделить ячейку и поместить туда число
Sub Test()
With Application.Workbooks.Item("Test.xls")
Worksheets("Лист2").Activate
Range("A2") = 2
Range("A3") = 3
End With
End Sub
Выделение отрицательных значений
Sub NegSelect()
Dim cell As Range
' Просмотр всех ячеек выделенного диапазона и пометка тех, _
которые содержат отрицательные значения
For Each cell In Selection
If cell.Value < 0 Then
|
cell.Interior.Color = RGB(255, 0, 0)
Else
cell.Interior.ColorIndex = xlNone
End If
Next cell
End Sub
Выделение диапазона и использование абсолютных адресов
Sub Test()
With Application.Workbooks.Item("Test.xls")
Worksheets("Лист2").Activate
Dim HelloRange As Range
Set HelloRange = Range("D3:D10") ‘можно через запятую выделять несколько интервалов или яче
HelloRange.Range("A1") = 3
End With
End Sub
Выделение ячеек через интервал_1
Sub IntervalCellSelect()
Dim intFirstRow As Integer ' Первая строка для выделения
Dim intLastRow As Integer ' Последняя строка для выделения
Dim rgCells As Range ' Объединение выделяемых ячеек
Dim intRow As Integer
intFirstRow = 3
intLastRow = 300
' Формирование объединения ячеек в столбце "B" от строки _
intFirstRow до строки intLastRow с шагом 3
For intRow = intFirstRow To intLastRow Step 3
If rgCells Is Nothing Then
' Первая ячейка в объединении
Set rgCells = Cells(intRow, 1)
Else
' Добавление очередной ячейки в объединение
Set rgCells = Union(rgCells, Cells(intRow, 1))
End If
Next
' Выделение всех ячеек в объединении
rgCells.Select
End Sub
Выделение ячеек через интервал_2
Sub IntervalCellSelect()
Dim intFirstRow As Integer ' Первая строка для выделения
Dim intLastRow As Integer ' Последняя строка для выделения
Dim rgCells As Range ' Объединение выделяемых ячеек
Dim cell As Range ' Текущая ячейка
Dim intRow As Integer
intFirstRow = 3
intLastRow = 300
' Формирование объединения ячеек в столбце "B" от строки _
intFirstRow до строки intLastRow с шагом 3
For intRow = intFirstRow To intLastRow Step 3
Set cell = Cells(intRow, 1)
Set rgCells = Union(cell, _
IIf(intRow = intFirstRow, cell, rgCells))
Next
' Выделение всех ячеек в объединении
rgCells.Select
End Sub
Выделение нескольких диапазонов
Sub SelectRange()
Range("D3:D10, A3:A10, F3").Select
End Sub
Движение по ячейкам
переменная.Offset(RowOffset, ColumnOffset)
В качестве переменных может выступать как ячейка так и диапазон (Range) удобно пользоваться этой функцией для смещения относительно текущей ячейки.
Например, смещение ввниз на одну ячейку и выделение ее:
ActiveCell.Offset(1, 0).Select
Если нужно двигаться вверх, то нужно использовать отрицательное число:
ActiveCell.Offset(-1, 0).Select
Функция ниже использует эту возможность для того, чтобы пробежаться вниз до первой пустой ячейки.
|
Sub beg()
Dim a As Boolean
Dim d As Double
Dim c As Range
a = True
Set c = Range(ActiveCell.address)
c.Select
d = c.Value
c.Value = d
While (a = True)
ActiveCell.Offset(1, 0).Select
If (IsEmpty(ActiveCell.Value) = False) Then
Set c = Range(ActiveCell.address)
c.Select
d = c.Value
c.Value = d
Else
a = False
End If
Wend
End Sub
Поиск ближайшей пустой ячейки столбца
Sub FindEmptyCell()
' Поиск ближайшей пустой ячейки в текущем столбце
Do While Not IsEmpty(ActiveCell.Value)
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Поиск максимального значения
Sub FindMaxValue()
On Error Goto NoCell
If Selection.Count > 1 Then
' Поиск максимального значения в выделенных ячейках
Selection.Find(Application.Max(Selection)).Select
Else
' Поиск максимального значения во всех ячейках листа
ActiveSheet.Cells.Find(Application.Max(ActiveSheet.Cells)).Select
End If
Exit Sub
NoCell:
MsgBox "Максимальное значение не найдено"
End Sub
Поиск и замена по шаблону
Sub ReplaceCellsData()
Dim cell As Range
' Просмотр всех ячеек диапазона G1:K20 и замена искомого текста
For Each cell In [G1:K20]
If cell.Value Like "*Доход*" Then
cell.Value = "Выручка"
cell.Interior.Color = RGB(255, 255, 0)
Else
cell.Interior.Color = RGB(255, 255, 255)
End If
Next
End Sub
Поиск значения с отображением результата в отдельном окне
Sub Search()
Dim rgResult As Range
' Поиск заданного значения в диапазоне B1:B20 и вывод результата
Set rgResult = Range("B1:B20").Find(9999,, xlValues)
If rgResult Is Nothing Then
MsgBox "Поиск не дал результатов"
Else
MsgBox rgResult.Address
End If
End Sub
Поиск с выделением найденных данных_1
Sub FindAndSelect()
Dim strStartAddr As String ' Хранит координаты первого найденного _
значения
Dim rgResult As Range
' Поиск первого входжения искомого слова
Set rgResult = Range("B1:B10").Find("Прибыль",, xlValues)
If Not rgResult Is Nothing Then
' Сохраним адрес найденной ячейки (чтобы контролировать _
зацикливание поиска)
strStartAddr = rgResult.Address
End If
Do While Not rgResult Is Nothing
' Обработка результата поиска
rgResult.Interior.Color = RGB(255, 255, 0)
' Новый поиск
Set rgResult = Range("B1:B10").FindNext(rgResult)
If rgResult.Address = strStartAddr Then
' Поиск завершен
Exit Do
End If
Loop
End Sub
Поиск с выделением найденных данных_2
Sub CustomSearch()
Dim strFindData As String
Dim rgFound As Range
Dim i As Integer
' Ввод строки для поиска
strFindData = InputBox("Введите данные для поиска")
' Просмотр всех рабочих листов книги
For i = 1 To Worksheets.Count
With Worksheets(i).Cells
' Поиск на i-м листе
Set rgFound =.Find(strFindData, LookIn:=xlValues)
If Not rgFound Is Nothing Then
|
' Ячейка с заданным значением найдена - выделим ее
Sheets(i).Select
rgFound.Select
Exit Sub
End If
End With
Next
' Поиск завершен. Ячейка не найдена
MsgBox ("Поиск не дал результатов")
End Sub
Поиск по условию в диапазоне
Option Explicit
Sub Поиск()
Dim iFoundRng As Range
Dim AutoNum As String
Dim firstAddress As String
Dim LastFoundRng As String
AutoNum = Range("E5")
If AutoNum = "" Then
MsgBox "Вы не указали номер авто в ячейке Е5!", 48, "Ошибка"
Exit Sub
End If
On Error Resume Next
LastFoundRng = ActiveWorkbook.Names("LastFoundRngName").RefersToRange.Address
If LastFoundRng = "" Then LastFoundRng = "$C$1"
With Columns("C")
Set iFoundRng =.Find(What:=AutoNum, After:=Range(LastFoundRng), LookIn:=xlFormulas, LookAt:=xlWhole)
If iFoundRng Is Nothing Then
MsgBox "Авто с номером " & AutoNum & " не найдено в столбце С!", "48", "Ошибка"
Exit Sub
End If
ActiveWorkbook.Names.Add Name:="LastFoundRngName", RefersTo:="=" & ActiveSheet.Name & "!" & iFoundRng.Address, Visible:=False
End With
[E7] = iFoundRng.Offset(0, 1)
[F7] = iFoundRng.Offset(0, 2)
End Sub
Поиск последней непустой ячейки диапазона
Function dhLastUsedCell(rgRange As Range) As Long
Dim lngCell As Long
' Пойдем по диапазону с конца (тогда первая попавшаяся _
заполненная ячейка и будет искомой)
For lngCell = rgRange.Count To 1 Step -1
If Not IsEmpty(rgRange(lngCell)) Then
' Нашли непустую ячейку
dhLastUsedCell = lngCell
Exit Function
End If
Next lngCell
' Непустую ячейку не нашли
dhLastUsedCell = 0
End Function
Поиск последней непустой ячейки столбца
Function dhLastColUsedCell(rgColumn As Range) As Variant
' Вывод значения последней непустой ячейки столбца
dhLastColUsedCell = rgColumn.Parent.Cells(Rows.Count, _
rgColumn.Column).End(xlUp).Value
End Function
Поиск последней непустой ячейки строки
Function dhLastRowUsedCell(rgRow As Range) As Variant
' Вывод значения последней непустой ячейки строки
dhLastRowUsedCell = rgRow.Parent.Cells(rgRow.Row, 256). _
End(xlToLeft).Address
End Function
Поиск ячейки синего цвета в диапазоне
Sub Макрос1()
Dim myRange As Range 'диапазон для поиска
Dim FoundRng As Range 'найденная ячейка
Dim iRow As Long
Dim iColumn As Long
Set myRange = Range("B1:B100")
Application.FindFormat.Interior.ColorIndex = 5 'будем искать синий цвет
Set FoundRng = myRange.Find(What:="", SearchFormat:=True)
If Not FoundRng Is Nothing Then
iRow = FoundRng.Row
iColumn = FoundRng.Column
MsgBox "Ячейка найдена по адресу: " & Chr(13) & "Ряд: " & iRow & Chr(13) & "Столбец: " & iColumn, vbInformation, ""
Else
MsgBox "Ячейка не найдена!", vbExclamation, ""
End If
|
End Sub
Поиск отрицательного значения в диапазоне и выделения синим цветом
Поиск наличия значения в столбце
Sub Макрос1()
Dim iCell As Range
Set iCell = Columns(1).Find(What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious)
If Not iCell Is Nothing Then
MsgBox "Номер последней заполненной строки в столбце A: " & iCell.Row,, ""
Else
MsgBox "Столбец ""A"" не содержит данных", vbExclamation, ""
End If
End Sub
Поиск совпадений в диапазоне
Option Explicit
Sub compare_areas()
Dim r As Range, ar As Range, nm As String, col As Range
Set r = Selection
If r.Count < 2 Then Exit Sub
'Dim r_prog As Integer
'r_prog = prog
'prog = 1
Application.ScreenUpdating = False
nm = ActiveSheet.Name
Sheets.Add
For Each ar In r.Areas
For Each col In ar.Columns
col.Copy
ActiveSheet.Paste
ActiveCell.SpecialCells(xlLastCell).Offset(1, 0).Select
Next
Next
Range(Cells(1, 1), Cells(r.Cells.Count, 2)).Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Cells(2, 2).FormulaR1C1 = "=IF((RC[-1]=R[-1]C[-1])+(RC[-1]=R[1]C[-1]),1,0)"
Range("b2").Select
Selection.AutoFill Destination:=Range(Cells(2, 2), Cells(r.Cells.Count + 1, 2)), Type:=xlFillDefault
Range(Cells(2, 2), Cells(r.Cells.Count + 1, 2)).Copy
Cells(2, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
For Each ar In r.Cells
If ar.Value <> Empty Then
If WorksheetFunction.VLookup(ar.Value, Range(Cells(2, 1), Cells(r.Count + 1, 2)), 2, 0) Then
ar.Interior.ColorIndex = 3
End If
End If
Next
Application.DisplayAlerts = False
ActiveSheet.Delete
Sheets(nm).Select
ActiveCell.Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'prog = r_prog
End Sub
Sub uncolor()
Selection.Interior.ColorIndex = xlNone
End Sub
Поиск ячейки в диапазоне_1
Dim r As Range
Dim foundCell As Range
Set r = ActiveSheet.Range("A1:A6")
Set foundCell = r.Find("Ichiro", LookIn:=xlValues)
If Not foundCell Is Nothing Then
foundCell.Select
Else
MsgBox "String not found."
End If
Поиск ячейки в диапазоне_2
Sub findtekst()
Dim c As Range
Set c = Range("c3:c98").Find("*ГКИ*",,, xlWhole)
If Not c Is Nothing Then c.Select
MsgBox (c)
End Sub
Также для финда по xlWhole вариации:
"*a" - заканчивается на a
"?a*" - 2-я буква a
"??a*" - 3-я буква а
"a?" - начинается на a и содержит ещё 1 любую букву
"a?*" - 2+ буквы минимум и начинается на a (например a1, a10, a12, a55, a55dd56 всё посчитается)
"*слово*" - находит слова содержащие "слово" в любой части строки (включая начало и конец)
"слово*" - находит ячейки начинающиеся со "слово" или просто ячейку "слово" без дополнительных букв
Поиск приближенного значения в диапазоне
Sub wwe()
Dim foundCell As Range
ActiveWorkbook.Names.Add Name:="ev", RefersToR1C1:= _
"=INDEX(Лист1!R11C2:R34C2,MATCH(MIN(ABS(Лист1!R36C2:R234C2-Лист1!R28C1)),ABS(Лист1!R36C2:R234C2-Лист1!R28C1),0))"
Set foundCell = [ev]
Names("ev").Delete
If Not foundCell Is Nothing Then
foundCell.Select
Else
MsgBox "String not found."
End If
End Sub
Поиск начала и окончания диапазона, содержащего данные
Sub FindSheetData()
' Выводим диапазон используемых ячеек листа
MsgBox ActiveSheet.UsedRange.Address
End Sub
Поиск начала данных
Sub FindStartOfData()
With ActiveSheet
' Заносим текст в ячейку, являющуюся левой верхней _
ячейкой используемого диапазона
.Cells(.UsedRange.Row,.UsedRange.Column).Value = _
|
"Начало данных"
End With
End Sub
Автоматическая замена значений
Sub ReplaceValues()
Dim cell As Range
' Проверка каждой ячейки диапазона на возможность замены _
значения в ней (отрицательные значения заменяются на -1, _
положительные - на 1)
For Each cell In Range("C1:C3").Cells
If cell.Value < 0 Then
cell.Value = -1
ElseIf cell.Value > 0 Then
cell.Value = 1
End If
Next
End Sub
Быстрое заполнение диапазона (массив)
Sub FillCells()
Dim intStartVal As Integer ' Начальное значение
Dim intStep As Integer ' Шаг при изменении значения
Dim intEndVal As Integer ' Конечное значение
Dim intVal As Integer ' Текущее значение
Dim intCellOffset As Integer ' Смещение от начальной ячейки
' Установка параметров заполнения
intStartVal = 1
intStep = 1
intEndVal = 100
' Заполнение ячеек текущего столбца значениями от 1 до 100
For intVal = intStartVal To intEndVal Step intStep
ActiveCell.Offset(intCellOffset, 0).Value = intVal
intCellOffset = intCellOffset + 1
Next intVal
End Sub
Заполнение через интервал(массив)
Sub FillCells()
Dim intStartVal As Integer ' Начальное значение
Dim intStep As Integer ' Шаг при изменении значения
Dim intEndVal As Integer ' Конечное значение
Dim intVal As Integer ' Текущее значение
Dim intCellOffset As Integer ' Смещение от начальной ячейки
Dim intCellStep As Integer ' Шаг при перемещении между _
заполняемыми ячейками
' Установка параметров заполнения
intStartVal = 3
intStep = 3
intEndVal = 30
intCellStep = 3
' Заполнение ячеек текущего столбца значениями от 3 до 30
For intVal = intStartVal To intEndVal Step intStep
ActiveCell.Offset(intCellOffset, 0).Value = intVal
intCellOffset = intCellOffset + intCellStep
Next intVal
End Sub
Заполнение указанного диапазона(массив)
Sub FillCellRect()
Dim lngRows As Long, intCols As Integer ' Количество ячеек по _
горизонтали и вертикали
Dim lngRow As Long, intCol As Integer ' Координаты текущей ячейки
Dim lngStep As Long, lngVal As Long
' Установка начального значения и шага заполнения
lngVal = 1
lngStep = 1
' Ввод количества ячеек по горизонтали и вертикали, которое _
необходимо заполнить
lngRows = Val(InputBox("Количество ячеек в высоту"))
intCols = Val(InputBox("Количество ячеек в ширину"))
' Отключение обновления экрана
Application.ScreenUpdating = False
' Заполнение ячеек значениями
For lngRow = 1 To lngRows
For intCol = 1 To intCols
ActiveCell.Offset(lngRow, intCol).Value = lngVal
lngVal = lngVal + lngStep
Next intCol
Next lngRow
' Включение обновления экрана
Application.ScreenUpdating = True
End Sub
Заполнение диапазона(массив)
Sub FillCellRect1()
Dim lngRows As Long, intCols As Integer
Dim lngRow As Long, intCol As Integer
Dim lngStep As Long, lngVal As Long
Dim alngValues() As Long
Dim rgRange As Range
' Установка начального значения и шага заполнения
lngVal = 1
lngStep = 1
' Ввод количества ячеек по горизонтали и вертикали, которое _
необходимо заполнить
lngRows = Val(InputBox("Количество ячеек в высоту"))
intCols = Val(InputBox("Количество ячеек в ширину"))
ReDim alngValues(1 To lngRows, 1 To intCols)
Set rgRange = ActiveCell.Range(Cells(1, 1), _
Cells(lngRows, intCols))
' Заполнение массива alngValues значениями
For lngRow = 1 To lngRows
For intCol = 1 To intCols
alngValues(lngRow, intCol) = lngVal
lngVal = lngVal + lngStep
Next intCol
Next lngRow
' Перенос значений из массива в таблицу
rgRange.Value = alngValues
End Sub
|
|
Организация стока поверхностных вод: Наибольшее количество влаги на земном шаре испаряется с поверхности морей и океанов (88‰)...
Археология об основании Рима: Новые раскопки проясняют и такой острый дискуссионный вопрос, как дата самого возникновения Рима...
Наброски и зарисовки растений, плодов, цветов: Освоить конструктивное построение структуры дерева через зарисовки отдельных деревьев, группы деревьев...
Историки об Елизавете Петровне: Елизавета попала между двумя встречными культурными течениями, воспитывалась среди новых европейских веяний и преданий...
© cyberpedia.su 2017-2024 - Не является автором материалов. Исключительное право сохранено за автором текста.
Если вы не хотите, чтобы данный материал был у нас на сайте, перейдите по ссылке: Нарушение авторских прав. Мы поможем в написании вашей работы!