Главная страница
Навигация по странице:

  • Sub KillUsedHiddenThinRows()Dim xFor Each x In ActiveSheet.UsedRange.RowsIf x.Hidden Or x.Height = 0 Then x.EntireRow.DeleteNextEnd Sub

  • Готовые макросы в VBA Excel (Миронов.) (z-lib.org). Запуск макроса с поиском ячейки 6 Запуск макроса при открытии книги 6


    Скачать 1.47 Mb.
    НазваниеЗапуск макроса с поиском ячейки 6 Запуск макроса при открытии книги 6
    Дата26.06.2022
    Размер1.47 Mb.
    Формат файлаdoc
    Имя файлаГотовые макросы в VBA Excel (Миронов.) (z-lib.org).doc
    ТипДокументы
    #615298
    страница15 из 47
    1   ...   11   12   13   14   15   16   17   18   ...   47

    Удаление скрытых строк


    Sub KillHiddenRows()
    For Each x In ActiveSheet.Rows
    If x.Hidden Then x.Delete
    Next
    End Sub

    Удаление используемых скрытых строк или строк с нулевой высотой


    Sub KillUsedHiddenThinRows()
    Dim x
    For Each x In ActiveSheet.UsedRange.Rows
    If x.Hidden Or x.Height = 0 Then x.EntireRow.Delete
    Next
    End Sub


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



    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
    1   ...   11   12   13   14   15   16   17   18   ...   47


    написать администратору сайта