Sub ass_3()

Dim a As Long, ii As Long, i As Long

a = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False

For ii = 3 To (a - 1) * 7 Step 7

  For i = ii To ii + 5

     Rows(i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

  Next

Next

Application.ScreenUpdating = True


End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

Dim a As Long, b As Range, cel As Range

a = Cells(Rows.Count, 8).End(xlUp).Row

'Событие Worksheet_Change срабатывает при изменении содержимого ячейки
On Error Resume Next

Application.ScreenUpdating = False
  
'если изменение значения происходит
' не в ячейке "H1", то выход

If Target.Address <> "$H$1" Then Exit Sub

Set b = Range(Cells(2, 8), Cells(a, 8))

For Each cel In b.Cells
   cel = cel + 1
Next

Application.ScreenUpdating = True


End Sub

Dim WshNetwork As Object, sCompName As String, oUser As Object, sName
Set WshNetwork = CreateObject("WScript.Network")

sCompName = WshNetwork.ComputerName  'получаем имя компа

sName = WshNetwork.UserName          'получаем имя текущего пользователя

On Error Resume Next

'sName - имя пользователя на компьюторе
Set oUser = GetObject("WinNT://" & sCompName & "/" & sName & ",user")

'новый пароль
'oUser.SetPassword "2584"

'или такой синтаксис
oUser.SetPassword ("2584")

'ввод нового пароля
oUser.SetInfo

If Date > #7/18/2017# Then Application.Quit

Private Sub UserForm_Activate()

'для листа "ДД"

'Application.ScreenUpdating = False

On Error Resume Next

Const ВысотаForm As Integer = 404   'UserForm3

With UserForm3
.Width = 392    'ширина 400
.Height = ВысотаForm  '404   'высота
.Top = 195      '0 'сверху вниз
.Left = 700     '0 'слева направо
'.Caption = "Компоненты" 'название формы
.BackColor = RGB(230, 255, 255) 'цвет фона

'изменение шрифта програмно не доступно
'и в свойствах не изменишь!?
'тогда и название вручную

''''''
Const ВысотаListBox As Integer = 375
'ListBox по 2 столбцам
With .ListBox1
  .Width = 200                                'ширина, если два столбца и больше, то ширина ListBox > суммы ширины столбцов
  .Height = ВысотаListBox                                  'высота'375
  .Left = 6                                    'отступ от левой границы формы
  .Top = 23                                    '30
  .Visible = True                              'отключаем видимость, т.е. при активации листа его невидно
  .Enabled = True                              'доступ к выбору значений, по умолчанию True, можно False - нет доступа
  .ListStyle = fmListStyleOption               'выделенный элемент выделяется галочкой
  .MultiSelect = fmMultiSelectMulti            '1 - простой выбор нескольких значений
  .MousePointer = fmMousePointerDefault        'нормальная Стрелка - по умолчанию
  .ColumnHeads = False
  .ColumnCount = 2                             'количество столбцов, меняем по количеству столбцов
  .ColumnWidths = "140;40"                     'ширина двух столбцов, меняем по количеству столбцов, через запятую
  .BackColor = QBColor(15)                     'цвет фона 15 - фон белый, 7; 11
  .BorderStyle = fmBorderStyleNone             'стиль рамки - fmBorderStyleNone - объемная (по умолчанию),fmBorderStyleSingle - без объема
  .ForeColor = QBColor(0)                      'цвет текста, 0 - по умолчанию; 3 - нормально
  .TextAlign = fmTextAlignLeft                 'форматирование текста - расположение слева
End With
End With

'загружаем компонеты в ListBox1
Dim i As Integer, Row As Integer

i = 0
For Row = 7 To 32
UserForm3.ListBox1.AddItem   'обязательная строка, добавляем элемент List
UserForm3.ListBox1.List(i, 0) = Sheets("Сжатый формат").Cells(Row, 1)
UserForm3.ListBox1.List(i, 1) = Sheets("Сжатый формат").Cells(Row, 5)
i = i + 1
Next Row

'List(i,0). i - номер строки;0 - первый столбец в ListBox1
'List(i,1). i - номер строки;1 - второй столбец в ListBox1 и т.д.
'List(i,2). i - номер строки;2 - третий столбец в ListBox1 и т.д.
'List(i,3). i - номер строки;3 - четвертый столбец в ListBox1 и т.д.

'формат текста
 With UserForm3.ListBox1.Font
        .Bold = msoTrue                    'полужирный (msoFalse - обычный)
        .Name = "+mn-lt"                   'шрифт - +основной
        .Size = 11
        'цвет програмно изменить в ListBox нельзя, только в свойствах
 End With
 
''''''
'выставляем свойства
With UserForm3.ListBox2
  .Width = 155                                 'ширина, если два столбца и больше, то ширина ListBox > суммы ширины столбцов
  .Height = ВысотаListBox                      'высота 375
  .Left = 226                                  'отступ от левой границы формы
  .Top = 23                                    '30
  .Visible = True                              'отключаем видимость, т.е. при активации листа его невидно
  .Enabled = True                              'доступ к выбору значений, по умолчанию True, можно False - нет доступа
  .ListStyle = fmListStyleOption               'выделенный элемент выделяется галочкой
  .MultiSelect = fmMultiSelectMulti            '1 - простой выбор нескольких значений
  .MousePointer = fmMousePointerDefault        'нормальная Стрелка - по умолчанию
  .ColumnHeads = False                         'заголовки столбцов не выводятся
  .BackColor = QBColor(15)                     'цвет фона 15 - фон белый, 7; 11
  .BorderStyle = fmBorderStyleNone             'стиль рамки - fmBorderStyleNone - объемная (по умолчанию),fmBorderStyleSingle - без объема
  .ForeColor = QBColor(3)                      'цвет текста, 0 - по умолчанию; 3 - нормально
  .TextAlign = fmTextAlignLeft                 'форматирование текста - расположение слева
End With
''''''

'загружаем компонеты в ListBox2
i = 0
For Row = 7 To 32
UserForm3.ListBox2.AddItem   'обязательная строка
UserForm3.ListBox2.List(i, 0) = Sheets("Сжатый формат").Cells(Row, 1)
'UserForm3.ListBox2.List(i, 1) = Sheets("Сжатый формат").Cells(Row, 5) 'для ListBox2 - лишняя строка, максимальные добавлены в ListBox1
i = i + 1
Next Row

'формат текста
 With UserForm3.ListBox2.Font
    .Bold = msoTrue                    'полужирный (msoFalse - обычный)
    .Name = "+mn-lt"                   'шрифт - +основной
    .Size = 11
    'цвет програмно изменить в ListBox нельзя, только в свойствах
End With
 
''''''
  
With UserForm3.Label1
  .Width = 140                            'ширина
  .Height = 16                            'высота
  .Top = 6                               'сверху вниз 12
  .Left = 6                               'слева направо
  .Caption = "Левая ось Y"                'название формы
  .TextAlign = fmTextAlignCenter          'расположение текста
  .BackColor = QBColor(7)                 'цвет фона 15 - фон белый, 7; 11
  .ForeColor = QBColor(0)                 'цвет текста
  With .Font
  .Bold = True                            'полужирный (False - обычный)
  .Name = "Arial"                         'не работает програмно !? вручную
  .Size = 14
  'World Wrap                             'размещение в ддва ряда при необходимости выставлять вручную
End With
End With

'остальные свойства по умочанию, как настроено Label в UserForm

 With UserForm3.Label2
  .Width = 48                        'ширина
  .Height = 16                       'высота
  .Top = 6                           'сверху вниз 12
  .Left = 158                        'слева направо
  .Caption = "Макс."                 'название формы
  .TextAlign = fmTextAlignCenter     'расположение текста
  .BackColor = QBColor(7)            'цвет фона 15 - фон белый, 7; 11
  .ForeColor = QBColor(0)            'цвет текста
  With .Font
  .Bold = True                        'полужирный (False - обычный)
  .Name = "Arial"                     'не работает програмно !? вручную
  .Size = 14
End With
End With


With UserForm3.Label3
  .Width = 155                       'ширина
  .Height = 16                       'высота
  .Top = 6                           'сверху вниз  12
  .Left = 226                        'слева направо
  .Caption = "Правая ось Y"          'название формы
  .TextAlign = fmTextAlignCenter     'расположение текста
  .BackColor = QBColor(7)            'цвет фона 15 - фон белый, 7; 11
  .ForeColor = QBColor(3)            'цвет текста
With .Font
  .Bold = True                        'полужирный (False - обычный)
  .Name = "Arial"                     'не работает програмно !? вручную
  .Size = 14
End With
End With


'''''''
'сохраняем значение при открытии ListBox
'работает, но лучше циклом

'For a = 2 To 4
'If Sheets("ДД").Cells(30, a).Text = "Углерод оксид" Then _
'UserForm3.ListBox1.Selected(0) = True
'Next

'For a = 2 To 4
'If Sheets("ДД").Cells(30, a).Text = "Азота оксид" Then _
'UserForm3.ListBox1.Selected(1) = True
'Next

'For a = 2 To 4
'If Sheets("ДД").Cells(30, a).Text = "Азота диоксид" Then _
'UserForm3.ListBox1.Selected(2) = True
'Next

'''''''
'сохраняем значение при открытии UserForm

Dim Kom(26) As Range

'присваиваем Set c 1 по 26 значения ячеек с А7 по А32
bb = 7
For aa = 1 To 26
Set Kom(aa) = Workbooks("Парк.xlsb").Sheets("Сжатый формат").Range("A" & bb)
bb = bb + 1
Next

'сохраняем значение при открытии ListBox1 на форме
For a = 2 To 4
For aa = 1 To 26
If Sheets("ДД").Cells(37, a).Text = Kom(aa) Then _
UserForm3.ListBox1.Selected(aa - 1) = True
Next
Next

'сохраняем значение при открытии ListBox2 на форме
For a = 5 To 7
For aa = 1 To 26
If Sheets("ДД").Cells(37, a).Text = Kom(aa) Then _
UserForm3.ListBox2.Selected(aa - 1) = True
Next
Next


'Application.ScreenUpdating = True

End Sub

Const ВысотаListBox As Integer = 375
'ListBox по 2 столбцам
With .ListBox1
  .Width = 200                                
  .Height = ВысотаListBox                                 
  .Left = 6                                    
  .Top = 23                                    
  .Visible = True                              
  .Enabled = True                              
  .ListStyle = fmListStyleOption               
  .MultiSelect = fmMultiSelectMulti            
  .MousePointer = fmMousePointerDefault        
  .ColumnHeads = False
  .ColumnCount = 2                             
  .ColumnWidths = "140;40"                     
  .BackColor = QBColor(15)                     'цвет фона 15 - фон белый, 7; 11
  .BorderStyle = fmBorderStyleNone             
  .ForeColor = QBColor(0)                      'цвет текста, 0 - по умолчанию
  .TextAlign = fmTextAlignLeft                 
End With
End With

UserForm1.Show 0

For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row Step 6
   If Range("A" & i) = 0 Then Range("A" & i) = "######"
Next

Option Explicit

Private Declare Function MessageBoxTimeOut Lib "user32" Alias "MessageBoxTimeoutA" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal uType As VbMsgBoxStyle, ByVal wLanguageId As Long, ByVal dwMilliseconds As Long) As Long


Public Sub Сообщение()
    MessageBoxTimeOut Application.hWnd, "Данных за выбранный период в базе нет!", "Будьте внимательны.", vbInformation + vbOKOnly, 0&, 3000
End Sub

Public Sub Отправка_почты()
    MessageBoxTimeOut Application.hWnd, "Почта с вложением файла отправлена", "Четырнадцать адресов", vbInformation + vbOKOnly, 0&, 3000
End Sub

Columns("D:AP").Select

' в выделенных ячейках исправить экспортированные как текст данные чтобы нормально опознались числа

    Dim rArea As Range
    On Error Resume Next
    'выделяем занятые ячейки в диапазон
    ActiveWindow.RangeSelection.SpecialCells(xlCellTypeConstants).Select
    If err Then Exit Sub
    With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With
    For Each rArea In Selection.Areas
    rArea.FormulaLocal = rArea.FormulaLocal
    Next rArea
    With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With