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

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

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

Sub SetCellData()

' Заполнение значениями ячеек А3 и В4

Range("A3") = "Данные для ячейки A3"

Range("B4") = "Данные для ячейки B4"

End Sub

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

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