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

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

Сделать лист невидимым

Sub Test()

With Application.Workbooks.Item("Test.xls")

.Sheets.Item("Лист5").Visible = False

End With

End Sub

Сколько страниц на всех листах?

Sub GetPrintPagesCount()

Dim wshtSheet As Worksheet

Dim intPagesCount As Integer

' Суммирование количества страниц, необходимых для печати всех _

листов книги

For Each wshtSheet In Worksheets

intPagesCount = intPagesCount + (wshtSheet.HPageBreaks.Count + 1) * _

(wshtSheet.VPageBreaks.Count + 1)

Next

MsgBox "Всего страниц: " & intPagesCount

End Sub

Ячейка и диапазон (столбцы и строки)

Копирование строк на другой лист

Sub CopyRows2()

Dim iCells As Range

For Each iCells In Range("A2:A5")

Range(iCells, iCells.Offset(, 7)).Copy

Workbooks.Add

ActiveSheet.Paste

ActiveWorkbook.SaveAs Filename:="C:\Temp\" & iCells & ".xls"

Next iCells

End Sub

Копирование столбцов на другой лист

On Error Resume Next

s = Names("sourcefilename").Value

On Error GoTo 0

If s = "" Then

sfile = "progcall234_56g"

Call get_file

s = sfile

Else

s = Mid(s, 3, Len(s) - 3)

End If

If s = "" Then Exit Sub

Workbooks.Open (s)

Dim snm As String

snm = ActiveWorkbook.Name

ncol = WorksheetFunction.CountA(Range("1:1")) ' Range("a1").SpecialCells(xlLastCell).Column

nrow = WorksheetFunction.CountA(Range("a:a")) 'Range("a1").SpecialCells(xlLastCell).Row

Range(Cells(1, 1), Cells(nrow, ncol)).Copy

Workbooks(s1).Activate

Range("a1").Activate

ActiveSheet.Paste

Application.DisplayAlerts = False

Workbooks(snm).Close

Подсчет количества ячеек, содержащих указанные значения_1

Function dhCount(rgn As Range, LowBound As Double, _

UpperBound As Double) As Long

Dim cell As Range

Dim lngCount As Long

' Проходим по всем ячейкам диапазона rgn и подсчитываем значения, _

попадающие в интервал от LowBound до UpperBound

For Each cell In rgn

If cell.Value >= LowBound And cell.Value <= UpperBound Then

' Значение попадает в заданный интервал

lngCount = lngCount + 1

End If

Next

dhCount = lngCount

End Function

Подсчет количества ячеек в диапазоне, содержащих указанные значения_2

Function dhCountSomeCells(rgRange As Range, dblMin As Double, _

dblMax As Double) As Long

' Расчет количества ячеек со значениями от dblMin до dblMax _

с использованием стандартной функции CountIf

With Application.WorksheetFunction

dhCountSomeCells = .CountIf(rgRange, ">=" & dblMin) - _

.CountIf(rgRange, ">" & dblMax)

End With

End Function

Подсчет количества видимых ячеек в диапазоне

Function dhCountVisibleCells(rgRange As Range)

Dim lngCount As Long

Dim cell As Range

' Проходим по всему диапазону и подсчитываем непустые _

видимые ячейки

For Each cell In rgRange

' Проверка, есть ли данные в ячейке

If Not IsEmpty(cell) Then

' Проверка, видима ли ячейка

If Not cell.EntireRow.Hidden And Not _

cell.EntireColumn.Hidden Then

' Еще одна видимая ячейка

lngCount = lngCount + 1

End If

End If

Next cell

dhCountVisibleCells = lngCount

End Function

Определение количества ячеек в диапазоне и суммы их значений

Sub CalculateSum()

Dim i As Integer

Dim intSum As Integer

' Расчет суммы ячеек столбца "A" (с первой по пятую)

For i = 1 To 5

intSum = intSum + Cells(i, 1)

Next

MsgBox "Сумма ячеек: " & intSum

End Sub

Подсчет количества ячеек

Sub CountOfCells()

MsgBox (Range("A1:A20, D1:D20").Count)

End Sub

Автоматический пересчет данных таблицы при изменении ее значений

Sub Worksheet_Change(ByVal Target As Range)

Dim rgData As Range

Dim cell As Range

Dim dblMax As Double, dblMin As Double, dblAverage As Double

' Получение контролируемого диапазона ячеек

Set rgData = Range("B2:B11")

' Проверка, не входит ли измененная ячейка в контролируемый _

диапазон

If Not (Application.Intersect(Target, rgData) Is Nothing) Then

If Application.WorksheetFunction.CountA(rgData) > 0 Then

' Изменена ячейка из контролируемого диапазона

' Заново рассчитываем минимальное, максимальное и среднее _

значения в контролируемом диапазоне ячеек

dblMin = Application.WorksheetFunction.Min(rgData)

dblMax = Application.WorksheetFunction.Max(rgData)

dblAverage = Application.WorksheetFunction.Average(rgData)

' Проверяем каждую ячейку из контролируемого диапазона _

и изменяем цвет шрифта ячеек с минимальным и максимальным _

значениями, а также помечаем желтым цветом ячейки _

со значениями больше среднего

For Each cell In rgData

If cell.Value = dblMax Then

' Ячейку с максимальным значением выделим красным цветом

cell.Font.Bold = True

cell.Font.Color = RGB(255, 0, 0)

ElseIf cell.Value = dblMin Then

' Ячейку с минимальным значением выделим синим цветом

cell.Font.Bold = False

cell.Font.Color = RGB(0, 0, 255)

Else

cell.Font.Bold = False

cell.Font.Color = RGB(0, 0, 0)

End If

If cell.Value > dblAverage Then

' Значение в ячейке больше среднего - выделим ее _

желтым цветом

cell.Interior.Color = RGB(255, 255, 0)

Else

cell.Interior.ColorIndex = xlNone

End If

Next

Else

rgData.Interior.ColorIndex = xlNone

End If

End If

End Sub