Готовые макросы в vba excel, Миронов Глава Макросы 9

• Название: Готовые макросы в vba excel, Миронов Глава Макросы 9
• Дата: 06.02.2018
• Размер: 1.35 Mb.
• Имя файла: 33980_7d1642e70814394f108d07a8a2edd23e.doc
• Тип: Документы; #35930
• страница: 18 из 47

Поиск совпадений в диапазоне

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