Утилиты про запас, чтобы было. АртеФакты

Public Function Строки_Слова_НЕНужные_Удалить(r As Range) _
       As String
    ' Тестом покрыта
     ' удалить строки содержащие в ячейке слово
 
    Строки_Удалить_по_Массиву_Слов _
            r, _
            Массив_Слов_НЕнужных
 
End Function
 
Public Function Массив_Слов_НЕнужных(Optional ByVal msg As String) _
       As Variant()
    ' Тестом покрыта
 
    Массив_Слов_НЕнужных = Array("Итого", "Всего")
 
End Function
 
Public Function Строки_Удалить_по_Массиву_Слов(r As Range, a1() As Variant) _
       As String
    ' Тестом покрыта
 
    If Mock.isAx(a1) = False Then Exit Function    '=>
 
    If r Is Nothing Then Exit Function    '=>
 
    Dim found As Range
 
    Dim x As Long: For x = LBound(a1) To UBound(a1)
 
        Строки_Удалить _
                Слово_Целиком_Ячейки_Найти_Все( _
                r, a1(x))
 
    Next
End Function
 
Public Function Слово_Целиком_Ячейки_Найти_Все(ByVal r As Range, ByVal str As String) _
       As Range
 
    Dim c As Range, found As Range, firstAddress As String
 
    With r
 
        Set c = .Find( _
                What:=str, LookAt:=xlWhole, MatchCase:=False)
 
        If Not c Is Nothing Then
 
            firstAddress = c.Address
 
            Do
 
                Set found = App_Union(found, c)
 
                Set c = .FindNext(c)
 
                If c Is Nothing Then Exit Do
 
            Loop While c.Address <> firstAddress
        End If
    End With
 
    Set Слово_Целиком_Ячейки_Найти_Все = found
 
End Function
 
Public Function Строки_с_Пустыми_Ячейками(ByVal r As Range) _
       As Range
 
    ' Тестом покрыта
     ' вернуть строки, если в части строки r есть пустые ячейки
 
    If r Is Nothing Then Exit Function     '=>
 
    Dim r_New As Range
 
    Dim ceLL As Range: For Each ceLL In r
 
        With ceLL
 
            If WorksheetFunction.CountBlank( _
               Application.Intersect(r.CurrentRegion, .EntireRow)) > 0 Then
 
                Set r_New = App_Union(r_New, .EntireRow)
 
            End If
         End With
     Next
 
    Set Строки_с_Пустыми_Ячейками = r_New
 
End Function
 
 
Public Function Строки_Удалить(r As Range) _
       As String
    ' Тестом НЕ покрыта
 
    If r Is Nothing Then Exit Function    '=>
 
    With r
 
        .EntireRow.Delete
 
    End With
End Function

Public Function Диап_Ужать_до_Столбца(ByVal r As Range, _
ByVal iCol As Long, Optional ByVal msg As String) _
As Range
‘ Тестом покрыта
‘ АртеФакт
‘ диапазон ужать до нужного столбца столбца

If r Is Nothing Then Exit Function ‘=>

With r

Set Диап_Ужать_до_Столбца = Application.Intersect(r, .Columns(iCol))

End With
End Function

 
Public Function Столбцы_Добавить(Optional ByVal msg As String) _
       As String
    ' Тестом покрыта
    ' If Mock.isAx(a2) = False Then Exit Function '=>
     ' If r Is Nothing Then Exit Function    '=>
 
    With R_work
 
        .Range(.Cells(1, 1), .Cells(1, Indent_Max)). _
                EntireColumn.Insert Shift:=xlToRight
 
    End With
End Function
 
Public Function Столбцы_Пустые_Удалить(rng As Range) As String
    ' столбцы пустые удалить ' тестом Покрыто опосредованно
 
    Dim r As Range, rDel As Range
 
    For Each r In rng.Columns
 
        If r.Text = "" Then
 
            Set rDel = App_Union(rDel, r)
 
        End If
    Next r
 
    If Not rDel Is Nothing Then
 
        With rDel.EntireColumn
 
            .Delete Shift:=xlToLeft
 
        End With
    End If
End Function

Public Function Лист_Создать(wb As Workbook, ByVal msg As String) _
As Worksheet
‘ тестом Покрыто опосредованно
‘ АртеФакт

With wb

.Worksheets.Add _
After:=.Worksheets(.Worksheets.Count)

End With

Set Лист_Создать = ActiveSheet

End Function

Public Function Лист_Удалить_по_Имени(wb As Workbook, ByVal msg As String) _
As String
‘ тестом Покрыто опосредованно
‘ АртеФакт

Dim appDispAlert As Boolean

With Application

appDispAlert = .DisplayAlerts
.DisplayAlerts = False

On Error Resume Next

wb.Worksheets(msg).Delete

On Error GoTo 0

.DisplayAlerts = appDispAlert

End With

Лист_Удалить_по_Имени = msg ‘ пригодиться, чтобы создать лист заново

End Function

Public Function Листы_нужные_Проверить(Optional ByVal msg As String) _
‘ тестом Покрыто опосредованно
‘ АртеФакт — ПолуФабрикат
Dim a1() As Variant
a1 = Array(«СМЕТА», «Шаблон Рабочка», «sss»)

Dim wb As Workbook
Set wb = ActiveWorkbook

Dim eL As Variant

For Each eL In a1

If Лист_Присутствует(wb, eL) = False Then msg = eL

Next

If msg <> vbNullString Then

MsgBox «Нет листа » & msg, vbCritical, «Выход»

End If
End Function

Public Function Лист_Присутствует(ByVal wb As Workbook, _
ws_Name As Variant) _
As Boolean
‘ тестом Покрыто опосредованно

‘ есть ли лист с таким имененм
‘ АртеФакт

Dim ws As Worksheet

For Each ws In wb.Worksheets

If UCase(ws.Name) = UCase(ws_Name) Then

Лист_Присутствует = True

Exit Function

End If
Next
End Function

Public Function Ячейка_Целиком_Снять(Optional ByVal msg As String)
» тестом Покрыто опосредованно
‘ для диалога поиска снять галочку

With Cells(1, 1)

.Find What:=»*», LookIn:=xlFormulas, LookAt:=xlPart

End With
End Function