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

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:="=График!$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

Sub ТО_ТР_смещ()
Application.ScreenUpdating = False
Dim TR1 As Long, TR0
For i = Range("I14").Row To Range("I15").End(xlDown).Row
'Set TR0 = Nothing
Set TR0 = Range(Cells(i, "T"), Cells(i, "AC")).Find("ТР", , xlValue, xlWhole, xlByColumns)
If Not TR0 Is Nothing Then
TR1 = WorksheetFunction.Match("ТР", Range(Cells(i, "T"), Cells(i, "AC")), 0)
End If
Next
End Sub

Sub Яч_б_ТО()
Application.ScreenUpdating = False
Dim Pob, Diap As Range
Dim T
Dim P As Long, K As Long
Worksheets("ТО ВЛ-6кВ, КТПН,ЛР 2024").Activate
Pob = 0
For i = 1096 To 1453
Application.StatusBar = i
T = Cells(i, "G")
Set Diap = Range(Cells(i, "D"), Cells(i, "AF"))
Pob = 0
If Cells(i, "BQ") = 0 Then
Set Pob = Worksheets("ТО ПС-35 2024").Range("D10:D1000").Find(T, , xlValues, xlWhole, xlByRows)
End If
If Not Pob Is Nothing Then
K = WorksheetFunction.CountIf(Worksheets("ТО ПС-35 2024").Range("D10:D1000"), T)
P = WorksheetFunction.Match(T, Worksheets("ТО ПС-35 2024").Range("D1:D1000"), 0) + K
Worksheets("ТО ПС-35 2024").Range(P & ":" & P).Insert
Diap.Copy
Worksheets("ТО ПС-35 2024").Cells(P, "A").PasteSpecial
Diap.Interior.Color = RGB(240, 230, 185)
End If
Next
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub

Sub МВ()
Dim Yach As Long
Dim Ps
Dim A As Long
Dim tYach As Boolean
Dim b
Dim P As Range
Application.ScreenUpdating = False
For i = 12 To 60
Application.StatusBar = i
On Error Resume Next
Ps = WorksheetFunction.Search(" ", Cells(i, "I"), WorksheetFunction.Search("яч.№", Cells(i, "I")))
On Error GoTo 0
If IsEmpty(Ps) = True Then Ps = 0
If Ps = 0 Then
A = Len(Cells(i, "I")) - WorksheetFunction.Search("№", Cells(i, "I"))
Else
A = WorksheetFunction.Search(" ", Cells(i, "I"), WorksheetFunction.Search("№", Cells(i, "I"))) - _
WorksheetFunction.Search("№", Cells(i, "I")) - 1
End If
b = WorksheetFunction.Search("№", Cells(i, "I"))
If Left(Cells(i, "H"), 2) = "Ф-" Then
Cells(i, "J") = WorksheetFunction.Substitute(Cells(i, "H"), "Ф-", "") & " " & Cells(i, "G")
Else
Yach = Mid(Cells(i, "I"), b + 1, A)
Cells(i, "J") = Yach & " " & Cells(i, "G")
End If
Next i
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub

Sub Переместить()
Dim Nai() As Variant, Poisk As Long, Np As Long
Application.ScreenUpdating = False
Np = Range("R:R").Column - 1
Nai = Array("ВЛ-6кВ Ф-14 ПС-35/6кВ К-1384", "ВЛ-6кВ Ф-6 ПС-35/6кВ К-1384", "ВЛ-6кВ Ф-9 ПС-35/6кВ К-1384", _
"ВЛ-6кВ Ф-4 ПС-35/6кВ К-330")
For i = 15 To 1500
Application.StatusBar = "строка " & i
If Cells(i, "BM") = Nai Then
Poisk = WorksheetFunction.Match("*", Range(Cells(i, "R"), Cells(i, "AC")), 0)
Cells(i, Np + Poisk).Copy
Cells(i, "Z").PasteSpecial
Cells(i, "Z").Interior.Color = vbRed
Cells(i, Np + Poisk).Clear
End If
Next i
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub

Sub Макрос4()
Dim ie As New InternetExplorer
ie.Visible = True 'чтобы отображать интерфейс браузера
ie.Navigate ("http://mysite")
Do While ie.ReadyState <> READYSTATE_COMPLETE
DoEvents
Loop
'Получаем элемент поля для ввода по его ID
Dim SearchBox As htmlinputelement
Set SearchBox = ie.document.getelementbyid("mx3307")
SearchBox.Focus
SearchBox.Click
Dim i As Integer
For i = 1 To Len(SearchBox.Value)
'симулируем нажатие клавиши в поле для ввода
raiseevent
ie.document.createevent("keyboardevent").initevent("keydown",true,true)
'симулируем отпускание клавиши в поле для ввода
raiseevent
ie.document.createevent("keyboardevent").initevent("keyup",true,true)
Next i
End Sub

Sub Тест()
Dim a As Long
Dim b As Long
Dim a1
Dim b1
Dim c
a = ActiveCell.Row - 2
b = ActiveCell.Row - 1
a1 = Cells(a, 1).Address
b1 = Cells(b, 1).Address
ActiveCell.Formula = "Sum(a1 & ":" & b1)"
End Sub

Sub Сопоставл_ТТ()
On Error Resume Next
Application.ScreenUpdating = False
Dim A As Long, B As String, C As String, D As Long, E As String
Dim C1 As String, C2 As String, C3 As String, C4 As String
Dim TTV As String
Dim C11 As Long, C21 As Long, C31 As Long
Dim f As Long, g As Integer, i As Long, h As Long
Dim k As Long, k1 As Long
Dim M As Long
Dim q As Range
Dim TTL As Long
Dim KL
M = 3
k1 = ActiveCell.Row
f = ActiveCell.Column
A = WorksheetFunction.Match("Источник, присоединение", Range(Cells(1, 1), Cells(1, 40)), 0)
For k = k1 To k1 + M
TTL = 0
    If Cells(k, f) <> 0 And WorksheetFunction.Search("РУ", Cells(k, f - (f - A + 1))) Then
     Cells(k, f) = Cells(k, f)
    Else
    'f = ActiveCell.Column
    'If k = 0 Then g = ActiveCell.Row Else g = ActiveCell.Row + 1
    'If Cells(g, f) = 0 Then
        Set q = Cells(k, f - (f - A + 1))
            C1 = Left(q.Value, WorksheetFunction.Search("--", q.Value) - 1)
        C11 = Len(C1)
        prov = WorksheetFunction.Search("--", q, _
            WorksheetFunction.Search("--", q) + 1)
        C2 = Mid(q, C11 + 3, WorksheetFunction.Search("--", q, _
            WorksheetFunction.Search("--", q) + 1) - WorksheetFunction.Search("--", q) - 2)
        C21 = Len(C2)
        C31 = Len(q) - C21 - C11 - 4
        C3 = Mid(q, C11 + C21 + 5, C31)
        C = Left(C3, 5)
        If Left(C, 4) = "МВ-6" Or Left(C, 4) = "ВВ-6" Or _
            Left(C, 5) = "СВВ-6" Or Left(C, 5) = "СМВ-6" Then
            B = "ТТ-6кВ"
            D = WorksheetFunction.Search(" ", C3, WorksheetFunction.Search _
                (" ", C3) + 1)
               ' KL = WorksheetFunction.Search("яч", C3)
            If D > 0 Then _
                C4 = Mid(C3, WorksheetFunction.Search("яч", C3) + 4, WorksheetFunction.Search(" ", _
                C3, WorksheetFunction.Search("яч", C3)) - WorksheetFunction.Search("яч", C3) - 4) _
            Else C4 = Mid(C3, WorksheetFunction.Search("яч", C3) + 4, Len(C3) - _
                WorksheetFunction.Search("яч", C3) - 3)
            TTV = C1 & "--" & C2 & "--ТТ-6кВ яч.№" & C4
            TTL = WorksheetFunction.Match(TTV, Range(Cells(1, f - (f - A + 1)), _
                Cells(4300, f - (f - A + 1))), 0)
            If D > 0 Then E = Left(B, D - 1) Else E = B
            Cells(k, ActiveCell.Column) = WorksheetFunction.Max _
            (Range(Cells(16, f), Cells(k1 + M, f))) + 1
            Cells(TTL, f) = Cells(k, f)
            Cells(k, f).Interior.Color = vbGreen
            Cells(TTL, f).Interior.Color = vbGreen
             Else
        Cells(k, f) = Cells(k, f)
         End If
    End If
    Application.StatusBar = "выполнено " & Round(k * 100 / M, 0) & " %"
Next
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub

Private Sub CommandButton3_Click()
Dim CA As New DataObject, CAkt1 As String
CAkt1 = label1.Caption
CA.SelText (CAkt1)
CA.PutInClipboard
End Sub

Sub Sogl()
On Error Resume Next
Dim ObjTag As Object
Dim ohtm As Object
Dim Sa As Variant
Dim Sa2 As Variant
Dim myShell As Object
   Dim myInternetExplorer As Object
    Set myShell = CreateObject(class:="Shell.Application")
       For Each myInternetExplorer In myShell.Windows
              'If myInternetExplorer.Name = "Internet Explorer" Then
              If myInternetExplorer.Name = "Mozilla Firefox" Then
              MsgBox ("MZ")
            Exit For
      End If
    Next myInternetExplorer
    If myInternetExplorer Is Nothing Then
    Exit Sub
   End If
   Dim i
   Dim s As Integer
   s = Application.InputBox("êîëè÷åñòâî ïîçèöèé", , , , , , , 1)
   For i = 1 To s
For Each ObjTag In myInternetExplorer.document.getElementsByTagName("Input")
If InStr(ObjTag.outerhtml, "fld text   fld fld_ro") > 0 Then
Sa2 = ObjTag.ID
Sa2 = Application.WorksheetFunction.Substitute(Sa2, "mx", "")
Sa2 = Sa2 + 716
Exit For
End If
Next
myInternetExplorer.document.getElementbyId("mx" & Sa2).Click
Application.Wait Time:=Now + TimeValue("0:00:6")
For Each ObjTag In myInternetExplorer.document.getElementbyId("dialogholder").getElementsByTagName("Button")
If InStr(ObjTag.outerhtml, "text pb") > 0 Then
Sa = ObjTag.ID
Exit For
End If
Next
myInternetExplorer.document.getElementbyId(Sa).Click
Application.Wait Time:=Now + TimeValue("0:00:6")
myInternetExplorer.document.getElementbyId("mx426_anchor").Click
Application.Wait Time:=Now + TimeValue("0:00:6")
Next
End Sub

Sub CopyResultFile2()
Sheets("график").Select
Dim Aktiv, NameAktiv, VidRem, PlanData, NomRZ, FaktData, Status
Dim DAktiv As Range, DNameAktiv As Range, DVidrem As Range, DPlandata As Range, 
DFaktdata As Range, DNomrz As Range, DStatus As Range, Dv As Range
Aktiv = WorksheetFunction.Match("Номер акт", Range(Cells(12, 1), Cells(12, 100)), 0)
NameAktiv = WorksheetFunction.Match("Наименование акт", Range(Cells(12, 1), Cells(12, 100)), 0)
VidRem = WorksheetFunction.Match("Вид рем", Range(Cells(12, 1), Cells(12, 100)), 0)
PlanData = WorksheetFunction.Match("Дата план", Range(Cells(12, 1), Cells(12, 100)), 0)
NomRZ = WorksheetFunction.Match("рабочее задание" _
, Range(Cells(12, 1), Cells(12, 100)), 0)
FaktData = WorksheetFunction.Match("Дата выполн/отказа", Range(Cells(12, 1), Cells(12, 100)), 0)
Status = WorksheetFunction.Match("Выполнение", Range(Cells(12, 1), Cells(12, 100)), 0)MsgBox (Aktiv & vbCr & NameAktiv & vbCr & VidRem & vbCr & PlanData & vbCr & NomRZ & vbCr & _
FaktData & vbCr & Status)Set DAktiv = Application.Range(Cells(14, Aktiv), Cells(89, Aktiv))
Set DNameAktiv = Application.Range(Cells(14, NameAktiv), Cells(89, NameAktiv))Set DVidrem = Application.Range(Cells(14, VidRem), Cells(89, VidRem))
Set DPlandatas = Application.Range(Cells(14, PlanData), Cells(89, PlanData))
Set DNomrz = Application.Range(Cells(14, NomRZ), Cells(89, NomRZ))
Set DFaktdata = Application.Range(Cells(14, FaktData), Cells(89, FaktData))
Set DStatus = Application.Range(Cells(14, Status), Cells(89, Status))
Set Dv = Application.Union(DAktiv, DNameAktiv, DVidrem, DPlandata, DNomrz, DFaktdata, DStatus).Select
Selection.Copy
End sub

#If VBA7 Then
Declare Function PtrSafe LoadKeyboardLayout Lib "User32" Alias "LoadKeyboardLaoutA" (ByVal pwszKLID As String, ByVal flags As LongPtr) As LongPtr
#Else
Declare Function LoadKeyboardLayout Lib "User32" Alias "LoadKeyboardLaoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long
#End If

Option Explicit
Private Sub CommandButton1_Click()
Dim FIO As String
Dim Akt
Dim add, add2
Dim TekPoz
FIO = Fam & " " & Imya & " " & otch
TekPoz = ActiveCell.Cells(1, 1)
Akt = MsgBox("активируйте ячейку, перед которой" _
& vbCr & "необходимо вставить данные", vbOKOnly, "Акктивируйте ячейку с ФИО")
add = ActiveCell.Row
add = add + 0
add2 = add + 1
Rows("add:add2").Select
End Sub

rows("add:add2").select 

rows("34:35"). select