Private Sub CommandButton1_Click()
    Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 2) = _
        Array(Val(Me.TextBox1), Me.TextBox2)
End Sub

Private Declare Function GetProfileString Lib "kernel32" _
Alias "GetProfileStringA" (ByVal lpAppName As String, _
ByVal lpKeyName As String, ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long) As Long

Dim vaList

Sub Print_Select()
    On Error Resume Next
    Application.ScreenUpdating = False
    Dim prncnt As Integer
    vaList = PrinterFind
    For prncnt = LBound(vaList) To UBound(vaList) ' èùåì ïðèíòåðû
        PrintForm.ComboBox1.AddItem vaList(prncnt)
    Next
    PrintForm.ComboBox1.Value = Application.ActivePrinter ' âûáîð ïðèíòåðà
    PrintForm.Show
    Application.ScreenUpdating = True
End Sub

Public Function PrinterFind(Optional Match As String) As String()
    Dim n%, lRet&, sBuf$, sCon$, aPrn$()
    Dim prnstr As Boolean
    Const lLen& = 1024, sKey$ = "devices"
    aPrn = Split(Excel.ActivePrinter)
    If InStr(aPrn(UBound(aPrn)), "(") Then prnstr = True
    sCon = " " & aPrn(UBound(aPrn) - 1) & " " '
    sBuf = Space(lLen)
    lRet = GetProfileString(sKey, vbNullString, vbNullString, sBuf, lLen)
    If lRet = 0 Then
        Err.Raise vbObjectError + 513, , "Can't read Profile"
        Exit Function
    End If
    aPrn = Split(Left(sBuf, lRet - 1), vbNullChar)
    If Match <> vbNullString Then aPrn = Filter(aPrn, Match, -1, 1)
    For n = LBound(aPrn) To UBound(aPrn)
        sBuf = Space(lLen)
        lRet = GetProfileString(sKey, aPrn(n), vbNullString, sBuf, lLen)
        If prnstr Then
            aPrn(n) = aPrn(n) & " (" & Mid(sBuf, InStr(sBuf, ",") + 1, lRet - InStr(sBuf, ",") - 1) & ":)"
        Else
            aPrn(n) = aPrn(n) & " on " & Mid(sBuf, InStr(sBuf, ",") + 1, lRet - InStr(sBuf, ",") - 1) & ":"
        End If
    Next
    PrinterFind = aPrn
End Function

.Attachments.Add Range("A4").Value

Sub www()
    Cells(3, 2).Copy Cells(1, 1).End(xlUp)(2)
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B4")) Is Nothing Then Exit Sub
    If IsNumeric(Target.Value) Then
        If Target.Value > Range("B6") Then
            ActiveSheet.Shapes("фигура").Fill.ForeColor.RGB = vbRed
        Else
            ActiveSheet.Shapes("фигура").Fill.ForeColor.RGB = vbWhite
        End If
    End If
End Sub

Sub Save_DT_1()
    Application.ScreenUpdating = False
        strFullName = "C:\Отправка\" & ActiveSheet.Range("R12") & "_" & ActiveSheet.Range("S12") & ".pdf"
    Application.ActivePrinter = "Microsoft Print to PDF (Ne02:)"
    ActiveSheet.PrintOut Copies:=1, PrToFileName:=strFullName
End Sub

Sub RedFontMerge()
    Dim arrOut(1 To 10, 1 To 2), strS As String, lngI As Long, lngJ As Long
     
    For lngJ = 1 To 10
        For lngI = 2 To ActiveSheet.UsedRange.Rows.Count
            If Cells(lngI, lngJ + 1).Font.Color = vbRed Then
                strS = strS & "," & Cells(lngI, lngJ + 1).Value
            End If
        Next lngI
        arrOut(lngJ, 1) = lngJ: arrOut(lngJ, 2) = Mid(strS, 2, Len(strS) - 1)
        strS = ""
    Next lngJ
    [AH2].Resize(10, 2).NumberFormat = "@"
    [AH2].Resize(10, 2) = arrOut
End Sub

Sub save_z()
Application.ScreenUpdating = False
Dim Rng As Range
Sheets("Лист1").Copy
Set Rng = Sheets("Лист1").UsedRange
With Rng
.Cells.Value = .Cells.Value
End With
ActiveSheet.DrawingObjects.Delete
ActiveWorkbook.SaveAs Filename:="C:\"& Cells (1, 1) & ".xlsx"
ActiveWindow.Close
Application.ScreenUpdating = True
End Sub

Sub spisok_gsm()
Application.ScreenUpdating = False
Dim LastRow As Long, Rw As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("Лист1")
        Rw = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        For i = 6 To LastRow
            If Cells(i, 11) <> " " Then
                Union(Cells(i, 1), Cells(i, 6), Cells(i, 7), Cells(i, 4), Cells(i, 2), Cells(i, 3), Cells(i, 5), Cells(i, 11), Cells(i, 15)).Copy .Cells(Rw, 1)
                Rw = Rw + 1
            End If
        Next
    End With
Application.ScreenUpdating = True
End Sub

Sub spisok_vid()
Application.ScreenUpdating = False
Dim LastRow As Long, Rw As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("Отчет1")
        Rw = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        For i = 4 To LastRow
            If Cells(i, 1) = "a" Then
                Range(Cells(i, 1), Cells(i, 24)).Copy .Cells(Rw, 1)
                Rw = Rw + 1
            End If
        Next
    End With
Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, Cancel As Boolean)
    If Not Intersect(target, Range("AU3") Is Nothing Then
    Call showform(target)
    Cancel = True
    End If
End Sub