Ввод данных с использованием формул

Sub SetCellFormula()

' Запись в ячейку А6 формулы "=A5+B5"

Range("A6") = "=A5+B5"

End Sub

Последовательный ввод данных

Sub StreamInput()

Dim strDate As String

Dim strSum As String

Dim lngRow As Long

' Ввод данных в цикле (повторяется до тех пор, пока пользователь _

не введет пустую строку или не нажмет "Отмена" в окне ввода)

Do

lngRow = Range("A65536").End(xlUp).Row + 1

' Ввод даты

strDate = InputBox("Вводим дату")

If strDate = "" Then Exit Sub

' Ввод выручки

strSum = InputBox("Вводим выручку")

If strSum = "" Then Exit Sub

' Запись данных в ячейки

Cells(lngRow, 1) = strDate

Cells(lngRow, 2) = strSum

Loop

End Sub

Ввод текстоввых данных в ячейки

Sub InsertCustomText()

' Заполнение текущей ячейки

ActiveCell = "Генеральный директор"

Selection.Font.Bold = True

' Фамилия на три столбца правее должности

Cells(ActiveCell.Row, ActiveCell.Column + 3).Select

ActiveCell.FormulaR1C1 = "А. Б. Рублев"

Selection.Font.Bold = True

 

' Ячейка с "Главный бухгалтер" на три столбца левее _

и на три строки ниже ячейки с фамилией директора

Cells(ActiveCell.Row + 3, ActiveCell.Column - 3).Select

ActiveCell = "Главный бухгалтер"

Selection.Font.Bold = True

' Фамилия на три столбца правее должности

Cells(ActiveCell.Row, ActiveCell.Column + 3).Select

ActiveCell = "Т. С. Копейкин"

Selection.Font.Bold = True

End Sub

 

Вывод в ячейки названия книги, листа и количества листов

Sub Test()

 Dim book As String

 Dim sheet As String

 Dim addr As String

 addr = "C"

 book = Application.ActiveWorkbook.Name

 sheet = Application.ActiveSheet.Name

 Workbooks(book).Activate

 Worksheets(sheet).Activate

 Range("A1") = book

 Range("B1") = sheet

 Dim xList As Integer

 xList = Application.Sheets.Count

 For x = 1 To xList

Dim s As String

s = addr + LTrim(Str(x))

Range(s) = x

 Next x

End Sub

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

Selection.SpecialCells(xlCellTypeBlanks).Select

Selection.Delete Shift:=xlUp

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

Sub DeleteEmptyStrings()

Dim intLastRow As Integer ' Номер последней используемой строки

Dim intRow As Integer ' Номер проверяемой строки

 

' Получение номера последней используемой строки

intLastRow = Worksheets(ActiveSheet.Index).UsedRange.Row + _

Worksheets(ActiveSheet.Index).UsedRange.Rows.Count - 1

' Счетчик устанавливается на используемую первую строку

intRow = Worksheets(ActiveSheet.Index).UsedRange.Row

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

Do While intRow <= intLastRow

If ActiveSheet.Rows(intRow).Text = "" Then

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

    ActiveSheet.Rows(intRow).Delete

    ' Данные сдвинулись вверх, поэтому номер последней _

     строки уменьшился, а текущей - не изменился

    intLastRow = intLastRow - 1

Else

    ' Текущая строка заполнена - переходим к следующей

    intRow = intRow + 1

End If

Loop

End Sub

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

Sub DeleteEmptyStrings1()

Dim intRow As Integer

Dim intLastRow As Integer

 

' Получение номера последней используемой строки

intLastRow = ActiveSheet.UsedRange.Row + _

ActiveSheet.UsedRange.Rows.Count - 1

 

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

For intRow = intLastRow To 1 Step -1

If ActiveSheet.Rows(intRow).Text = "" Then

    ActiveSheet.Rows(intRow).Delete

End If

Next intRow

End Sub

Удаление строки по условию

Sub Макрос1()
Dim iRange As Range
Dim TextToFindArray As Variant
Dim i As Long

TextToFindArray = Array("Toyota", "ВАЗ")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
For i = 0 To 1
With ActiveSheet.Cells
Set iRange =.Find(What:=TextToFindArray(i), LookIn:=xlFormulas, LookAt:=xlPart)
If Not iRange Is Nothing Then
Do
iRange.EntireRow.Delete
Set iRange =.Find(What:=TextToFindArray(i), LookIn:=xlFormulas, LookAt:=xlPart)
Loop While Not iRange Is Nothing
End If
End With
Next i
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
MsgBox "Строки с текстом " & TextToFindArray(0) & " и " & TextToFindArray(1) & " удалены!", 64, "Конец"
End Sub

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

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