Sub Дата()
Dim a As Range
Range("A1") = DateSerial(2025, 1, 1)
Set a = Range("A1").Find("January", , xlValues, xlPart)
If a Is Nothing ThenDebug.Print ("значение не найдено")
Else
Debug.Print ("Январь")
End If
End Sub

Sub Дата()
Dim a As Range
Range("A1") = DateSerial(2025, 1, 1)
Set a = Range("A1").Find("Январь", , xlValues, xlPart)
If a Is Nothing Then
Debug.Print ("значение не найдено")
Else
Debug.Print ("Январь")
End If
End Sub

private sub workbook_open()
with Лист1.combobox1
.clear
.additem "Январь"
.additem "Февраль"
end with
end sub

Sub Test
Range("A1").Activate 
End sub

Sub Сек()
Dim Typ As String 
Dim Curr As String 
Dim Ps As String 
Dim Vid As String 
Dim nCurr As Integer 
Dim nPs As Integer 
Dim nVid As Integer 
Dim I As Integer
Dim yach As Byte
nPs = WorksheetFunction.Match("Тип", Range("A14:Z14"), 0)
nCurr = WorksheetFunction.Match("Вид", Range("A14:Z14"), 0)
nVid = WorksheetFunction.Match("наименование", Range("A14:Z14"), 0)
Set adrCurr = Cells(14, nCurr)
Set adrPs = Cells(14, nPs)
'MsgBox (adrCurr.Value)

For I = 16 To 16

If Cells(I, nCurr).Value = "Оборудование" Then
    If Cells(I, nPs).Value = "ST=7" Or Cells(I, nPs).Value = "С2" Then
        if Right(Cells(I, nVid).Value, 2) = "№1" Or Mid(Cells(I, nVid).Value, WorksheetFunction.Search("яч", Cells(I, nVid)+3), _
         if isErr(WorksheetFunction.Search(" ", Cells(I, nVid), Search("яч", Cells(I, nVid)) + 1)) = False Then _
                worksheetfucntion.len(cells(i,nvid)) - worksheetfunction.Search(" ",cells(i,nvid),search("яч", cells(i,nvid)+3) else _
                worksheetfunction.len(cells(i,nvid)) -(worksheetfunction.Search("яч",cells(i,nvid))+3 <11 or _
                chr(right(cells(i, nvid),1) < 57 then
                
                Typ = "СШ-1"
                Else
                Typ = "СШ-2"
                End If
                End If
                worksheetfucntion.Len (Cells(I, nVid))
                End Sub

Sub Сцепить_запятая()Dim xRg As Variant, sptChar As StringDim Concatenatevisible As StringDim Scm As New DataObjectRazdelitel.ShowsptChar = Razdelitel.tXtSet xRg = Selection    Dim rg As Range    For Each rg In xRg        If (rg.EntireRow.Hidden = False) And (rg.EntireColumn.Hidden = False) Then            Concatenatevisible = Concatenatevisible & rg.Value & sptChar        End If    Next    Concatenatevisible = Left(Concatenatevisible, Len(Concatenatevisible) - Len(sptChar))    SetClipBoardText (Concatenatevisible)       MsgBox ("Значение" & Concatenatevisible & vbCr & "скопировано в буфер")End Sub

Sub test()
Dim Dat as string
Dim cDat as date
Dim M as byte, D as byte, Y as byte
Dim NewD
Dat="10.01.2024"
cdat=cDate(Dat)
D = day(cDat)
M= month(cDat)
Y=year(cDat)
NewD = msgbox(D & "." & M & "." & Y)
End Sub

Sub Test2 
On error resume next 
dim ST() 
Dim SI
ST = array(Textbox1, Textbox2, Textbox3)
SI = ST(2).name 'Значение SI будет "Textbox3" 
'далее хочу чтобы в завимости от индекса ST чтобы автоматически закращивался нужный Textbox1 
SI.backcolor = vbGreen 'формула не работает, никакой Textbox не меняет цвет 
textbox3.backcolor = vbgreen ' вот так работает, но нужно указывать вручную
End sub

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim cmdBarBut As CommandBarButton
    On Error Resume Next
With Application
    .CommandBars("cell").Controls("сцепить_запятая").Delete
    Set cmdBarBut = .CommandBars("cell").Controls.Add(Temporary:=True)
End With
        With cmdBarBut
            .Caption = "сцепить_запятая"
            .Style = msoButtonCaption
            .OnAction = "сцепить_запятая"
        End With
    On Error GoTo 0
End Sub

Sub Сцепить_запятая()
Dim D As Range, R As String, BP As Boolean
Dim avData, lr As Long, lc As Long, sRes As String
Dim oDict As Object, sTmpStr
Dim Scm As New DataObject
    Set oDict = CreateObject("Scripting.Dictionary")
    oDict.comparemode = 1
    Set D = Selection
    avData = D.Value
    R = ","
    If Not IsArray(avData) Then
        Scm = avData
        Exit Sub
    End If
 
    For lc = 1 To UBound(avData, 2)
        For lr = 1 To UBound(avData, 1)
            If Len(avData(lr, lc)) Then
                sRes = sRes & R & avData(lr, lc)
                If БезПовторов Then
                    If Not oDict.exists(avData(lr, lc)) Then
                        oDict.Add avData(lr, lc), 0&
                    End If
                End If
            End If
        Next lr
    Next lc
    If Len(sRes) Then
        sRes = Mid(sRes, Len(R) + 1)
    End If
 
    If BP Then
        sRes = ""
        sTmpStr = oDict.keys
        For lr = LBound(sTmpStr) To UBound(sTmpStr)
            sRes = sRes & IIf(sRes <> "", R, "") & sTmpStr(lr)
        Next lr
    End If
Scm.SetText (sRes)
Scm.PutInClipboard
    MsgBox ("Значение" & sRes & vbCr & "скопировано в буфер")
End Sub

Private Sub workbook_deaktivate()
On Error Resume Next
With Application
CommandBars("cell").Controls("mymacro").Delete
End With
On Error GoTo 0
End Sub

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)Dim cmdBarBut As CommandBarButton On Error Resume NextWith ApplicationCommandBars("cell").Controls("MyMacro").DeleteSet cmdBarBut = .CommandBars("cell").Controls.Add(Temporary:=True)End WithWith cmdBarBut.Caption = "mymacro".Style = msoButtonCaption.OnAction = "mymacro"End With On Error GoTo 0End Sub

Sub Добавить_имена()
Worksheets("График").Names.Add Name:="namecount", RefersToR1C1:=Range("CJ15:CJ4200")
Worksheets("График").Names.Add Name:="namecount2", RefersToR1C1:=Range("CM15:CM4200")
Worksheets("График").Names.Add Name:="namecount3", RefersToR1C1:=Range("CS15:CS4200")
Worksheets("График").Names.Add Name:="namecount4", RefersToR1C1:=Range("BP15:BP4200")
Worksheets("График").Names.Add Name:="namelist", RefersToR1C1:=Range("CJ15:CK4200")
Worksheets("График").Names.Add Name:="namelist2", RefersToR1C1:=Range("CM15:CM4200")
Worksheets("График").Names.Add Name:="namelist3", RefersToR1C1:=Range("CS15:CT4200")
Worksheets("График").Names.Add Name:="namelist4", RefersToR1C1:=Range("BP15:CBQ4200")
End Sub

Sub Добавить_имена()
Worksheets("График").Names.Add Name:="namecount", RefersToR1C1:="=График!$CJ$15:$CJ$4200"
Worksheets("График").Names.Add Name:="namecount2", RefersToR1C1:="=График!$CM$15:$CM$4200"
Worksheets("График").Names.Add Name:="namecount3", RefersToR1C1:="=График!$CS$15:$CS$4200"
Worksheets("График").Names.Add Name:="namecount4", RefersToR1C1:="=График!$BP$15:$BP$4200"
Worksheets("График").Names.Add Name:="namelist", RefersToR1C1:="=График!$CJ$15:$CK$4200"
Worksheets("График").Names.Add Name:="namelist2", RefersToR1C1:="=График!$CM$15:$CM$4200"
Worksheets("График").Names.Add Name:="namelist3", RefersToR1C1:="=График!$CS$15:$CT$4200"
Worksheets("График").Names.Add Name:="namelist4", RefersToR1C1:="=График!$BP$15:$CBQ$4200"
End Sub

Sub Заполнение()
'On Error Resume Next
Dim Naimenov As String, Diapazon1 As Integer, Diapazon2 As Integer, Diapazon As Integer
Dim Nalichie As Boolean
Dim Drabot As Range, DVstavki As Range

Dim Pr1, Pr2
For i = 16 To 16
Naimenov = Left(Range("I" & i), 7)
Select Case Naimenov
Case "Присоед", "Секцион"
Nalichie = True
End Select
If Nalichie = True Then
    Set Drabot = Range("R" & i & ":" & "AC" & i)
    Pr1 = Range("I" & i + 1 & ":" & "I1200").Address
    Diapazon1 = WorksheetFunction.Match("Присоед", Range("I" & i + 1 & ":" & "I1200"), 0) - 1
    Diapazon2 = WorksheetFunction.Match("Секцион", Range("I" & i + 1 & ":" & "I1200"), 0) - 1
    If Diapazon1 < Diapazon2 Then Diapazon = Diapazon1 + i Else Diapazon = Diapazon2 + i
    Set DVstavki = Range("R" & i + 1 & ":" & "AC" & Diapazon)
    Pr2 = DVstavki.Address
    Drabot.Copy
    DVstavki.FillDown
End If
Next i
End Sub

Sub Протянуть_нумерацию()
On Error Resume Next
Dim Ch, Lh, Nh, P
Dim CRed, CBlue, CDBlue, Cwhite
Ch = 0
Nh = 0
Lh = 0
P = 0
CRed = RGB(255, 200, 180)
CBlue = RGB(221, 235, 247)
CDBlue = RGB(184, 204, 228)
Cwhite = RGB(255, 255, 255)
For i = 15 To 20
Application.StatusBar = i
If Cells(i, "D").Interior.Color = CDBlue Then
Nh = Nh + 1
Ch = WorksheetFunction.Roman(Nh)
Cells(i, "D") = Ch
Else
If Cells(i, "D").Interior.Color = Cwhite Then
Lh = Lh + 1
Cells(i, "D") = Lh
Else
If Cells(i, "D").Interior.Color = CBlue Then

    If Cells(i, "D").Interior.Color <> Cells(i - 1, "D").Interior.Color Then _
    Cells(i, "D") = CStr(Cells(i - 1, "D")) & "." & CStr(Right(Cells(i - 1, "D"), 1)) Else
    Cells(i, "D") = CStr(Left(Cells(i - 1, "D"), Len(Cells(i - 1, "D")) - 3)) & "." & _
    CStr(Right(Cells(i - 1, "D"), 1) + 1)
End If
End If
End If
Next
Application.StatusBar = False
End Sub

Sub Копирование_строк()
Dim NmSh As String, NmF As String, NewWb As String
Dim Rp
Application.ScreenUpdating = False
Dim n As Integer
Dim k As Integer, k1 As Integer
Dim m As Double, m1 As Double
n = Application.InputBox("Количество вставляемых строк", , , , , , , 1)
Do While n > 1000
n = Application.InputBox("Количество вставляемых строк", , , , , , , 1)
If n > 1000 Then '1
MsgBox ("вы ввели слишком много строк")
End If
Loop
If n = 0 Then
MsgBox ("вы не ввели никаких данных")
Exit Sub
End If
For i = 1 To n
m = n Mod 10
m1 = n Mod 100
    k = n - m
    k1 = n - m1
If i <= 10 Then '2
    Rows(Selection.row & ":" & Selection.row).Select
    With Selection
        .Copy
        .Insert Shift:=xlUp
    End With
End If
If i > 10 And i <= 100 Then '3
    i = i + 9
    If i <= 10 Then  '3.1
    Rows(Selection.row & ":" & Selection.row).Select
    With Selection
        .Copy
        .Insert Shift:=xlUp
    End With
    Else
    If i > 10 And i < k Then  '3.2
    Rows(Selection.row & ":" & Selection.row - 9).Select
    With Selection
        .Copy
        .Insert Shift:=xlUp
    End With
    Else
    If i > k And i < n Then '3.3
    i = i + 1
    Rows(Selection.row & ":" & Selection.row).Select
    With Selection
        .Copy
        .Insert Shift:=xlUp
    End With
    End If '3.3
    End If '3.2
    End If '3.1
    End If  '3
If i > 100 And i <= 1000 Then '4
      i = i + 99
    If i <= 10 Then  '4.1
    Rows(Selection.row & ":" & Selection.row).Select
    With Selection
        .Copy
        .Insert Shift:=xlUp
    End With
    Else
    If i > 10 And i < k Then  '4.2
    Rows(Selection.row & ":" & Selection.row - 9).Select
    With Selection
        .Copy
        .Insert Shift:=xlUp
    End With
    Else
    If i > 100 And i < k1 Then  '4.3
    Rows(Selection.row & ":" & Selection.row - 99).Select
    With Selection
        .Copy
        .Insert Shift:=xlUp
    End With
    Else
    If i > k And i < n Then '4.4
    i = i + 1
    Rows(Selection.row & ":" & Selection.row).Select
    With Selection
        .Copy
        .Insert Shift:=xlUp
    End With
    End If
    End If
    End If
    End If
    End If
   Application.StatusBar = i
    If i = n Then MsgBox ("успешно всталено " & i & "строк")
 Next i
 Application.ScreenUpdating = True
 Application.StatusBar = False
 End Sub

Sub Длина_ВЛ()
Application.ScreenUpdating = False
Dim S As Variant, Length As Integer, Ei As String, Poz As Long
Dim Np As Long, Kp As Long
Np = Range("I15").Row
Kp = Range("I15").End(xlDown).Row - 1
For i = Np To Kp
Application.StatusBar = "Строка" & i & " из " & Kp
Set S = Worksheets("Лист1").Range("C:C").Find(Range("BM" & i), , xlValues, xlWhole, xlByRows)
Ei = Range("L" & i)
If Not S Is Nothing And Ei = "км" Then
Poz = WorksheetFunction.Match(S, Worksheets("Лист1").Range("C:C"), 0)
Length = Worksheets("Лист1").Range("D" & Poz)
Range("M" & i) = Leng
End If
Next i
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub

Set TR0 = Range(Cells(i, "T"), Cells(i, "AC")).Find("ТР", , xlValues, xlWhole, xlByColumns)