Удаление дубликатов по маске

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