Private Sub CommandButton2_Click()

Dim OshB(8), OshW(8), OshQ(8), OshE(4), h, u, Za, v As String
Dim wLastRow, oLastRow, az, ao, dso As Long
Set wb = ThisWorkbook.Worksheets(1)
Set ob = ThisWorkbook.Worksheets(2)
    
      OshW(0) = "Изменение процесса без отчетности, с требованиями"
      OshW(1) = "Изменение отчета без процесса, с требованиями"
      OshW(2) = "Изменение процесса и отчета, с требованиями"
      OshW(3) = "Изменение процесса без отчетности, без требований"
      OshW(4) = "Изменение отчета без процесса, без требований"
      OshW(5) = "Изменение процесса и отчета, без требований"
      OshW(6) = "Технические изменения"
      OshW(7) = "Не удалось классифицировать"
      u = Join(OshW, ",") 'Новая функциональность, Улучшение
      
      OshQ(0) = "Запрос на консультацию"
      OshQ(1) = "Корректировка данных"
      OshQ(2) = "Проведение анализа без доработок"
      OshQ(3) = "Изменение процесса без отчетности, без требований"
      OshQ(4) = "Технические операции"
      OshQ(5) = "Формирование документации"
      OshQ(6) = "Непроизводственные трудозатраты"
      OshQ(7) = "Не удалось классифицировать"
      Za = Join(OshQ, ",") 'Задача
      
      
      wLastRow = wb.Cells(1, 1).CurrentRegion.Rows.Count
      For dsw = 2 To wLastRow
      If wb.Cells(dsw, 3) Like "Задача" Then
      wb.Cells(dsw, 9).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Za
      Else: wb.Cells(dsw, 9).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=u
      End If

Dim OshB(8), OshW(8), OshQ(8), OshE(4), h, u, Za, v As String
Dim wLastRow, oLastRow, az, ao, dso As Long
Set wb = ThisWorkbook.Worksheets(1)
Set ob = ThisWorkbook.Worksheets(2)

oLastRow = ob.Cells(1, 1).CurrentRegion.Rows.Count 'лист "ошибки"
Application.AskToUpdateLinks = False
      OshB(0) = "Отмененные ошибки (в т.ч. Вошедшие в другие задачи)"
      OshB(1) = "Исторические ошибки"
      OshB(2) = "Ошибки переноса кода"
      OshB(3) = "Ошибки тестирования"
      OshB(4) = "Ошибки данных или действий заказчика"
      'OshB(5) = "Ошибки анализа"
      OshB(6) = "Ошибки разработки"
      OshB(7) = "Ошибки проектирования" '"Ошибки внедрения нового функционала"
      'OshB(8) = "Ошибки наложения функционала"
      h = Join(OshB, ",") 'ошибки
      For dso = 2 To oLastRow
      On Error Resume Next
      ob.Cells(dso, 9).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=h
      Next

Set wb = ThisWorkbook.Worksheets("Лист1")
For b= 2 to 100
With wb.Cells(b, 9).ComboBox1
        .AddItem "Действие 1"
        .AddItem "Действие 2"
        .AddItem "Действие 3"
End With
wb.Cells(b, 9).Show

URL2 = "https://jira.хххх.local/browse/" & sb.Cells(a, 1)
     Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
     XMLHTTP.Open "GET", URL2, False
     XMLHTTP.SEND
     Txt = XMLHTTP.responseText
     n = InStr(1, Txt, "jira-issue-status-lozenge-max-width-medium")
     k = InStr(n, Txt, "</span>")
     If InStr(1, Replace(Mid(Txt, n, k - n), " ", " "), "АААА", vbTextCompare) > 0 Then wb.Cells(b, 5) = "а!"
     If InStr(1, Replace(Mid(Txt, n, k - n), " ", " "), "ББББ", vbTextCompare) > 0 Then wb.Cells(b, 5) = "б!"
     On Error Resume Next


     n1 = InStr(1, Txt, "fixVersions-field")
     k1 = InStr(n1, Txt, "</span>")
     k2 = InStr(n1, Txt, "ЗЗЗ 3.1.1")
          'Ttxt1 = Replace(Mid(Txt, n1, k1 - n1), " ", " ")
          'TTxt2 = Replace(Mid(Txt, n1, k2 - n1), " ", " ")
     If InStr(1, Replace(Mid(Txt, n1, k1 - n1), " ", " "), "ЗЗЗ 3.1.1", vbTextCompare) > 0 Then wb.Cells(b, 6) = Mid(Txt, k2 - n1, 3)
     'If InStr(1, Replace(Mid(Txt, n1, k1 - n1), " ", " "), "РРР-2", vbTextCompare) > 0 Then wb.Cells(b, 6) = Right(Mid(Txt, n1, k - n1), 9)
     
    b = b + 1

Sub Сканировать()
    Dim x As Object
    Set WshShell = CreateObject("WScript.Shell")
    Set WshExec = WshShell.Exec("Microsoft Edge")
    x = Shell("""C:\Program Files (x86)\Microsoft\Edge\Application\msedge.exe""" & """https://jira.sibur.local/projects/CK1CNIPI?selectedItem=com.atlassian.jira.jira-projects-plugin%3Arelease-page&status=released-unreleased""", vbNormalFocus, True)
    Res = WshShell.AppActivate(WshExec.ProcessID)
    If Res Then WshShell.SendKeys ("^a^c")
    Set WshExec = WshShell.Exec("Microsoft Excel")
    Res = WshShell.AppActivate(WshExec.ProcessID)
    Set wb = ThisWorkbook.Worksheets("Лист3")    'база рабочая
    wb.Paste
End Sub

Sub skan()
Dim xhr As New XMLHTTP60
xhr.Open "GET", "страница в интернете", False
xhr.send
    If xhr.Status = 200 Then 'If xhr.Status >= 200 And xhr.Status < 300 Then
        Debug.Print xhr.responseText
    Else
        Debug.Print xhr.responseText
    End If
Set Tl1 = ThisWorkbook.Worksheets("Лист1")
Set tl2 = ThisWorkbook.Worksheets("Лист2")
xhr.Select
tl2.Activate
 ActiveSheet.Paste
End Sub

For nstr1 = 4 To Sh1.Cells.SpecialCells(xlLastCell).Row 
     Sh1.Rows(nstr1).Delete 
Next

Rows(4 & ":" & Sh1.Cells.SpecialCells(xlLastCell).Row).EntireRow.Delete

Sub base()
Dim wLastRow, qLastRow, s, PosStr As Long
Dim wb, base As Worksheet
Application.ScreenUpdating = False: Application.EnableEvents = False
Set wb = ThisWorkbook.Worksheets("Лист1") 'база рабочая
If IsBookOpen("БазаРаботТестирования.xlsx") Then
    Set basejob = Workbooks("БазаРаботТестирования.xlsx")
Else
    Set basejob = Workbooks.Open("C:\Users\mayorovab\Documents\БазаРаботТестирования.xlsx")
End If
Set base = basejob.Worksheets("Лист1") 'база общая
wLastRow = wb.Cells(1, 1).CurrentRegion.Rows.Count
qLastRow = base.Cells(1, 1).CurrentRegion.Rows.Count
'определяем есть ли вносимый элемент в общей базе если нет то добавляем если есть то редактируем
For s = 3 To wLastRow
    qLastRow = base.Cells(1, 1).CurrentRegion.Rows.Count
    Set QCellFind = base.Range("A:A").Find(wb.Cells(s, 1), , xlValues, xlWhole)
    If Not QCellFind Is Nothing Then PosStr = QCellFind.Row Else PosStr = qLastRow + 1
    base.Cells(PosStr, 1) = wb.Cells(s, 1).Value
    base.Cells(PosStr, 2) = wb.Cells(s, 2).Value
    base.Cells(PosStr, 3) = wb.Cells(s, 3).Value
    base.Cells(PosStr, 4) = wb.Cells(s, 4).Value
    base.Cells(PosStr, 5) = wb.Cells(s, 5).Value
    base.Cells(PosStr, 6) = wb.Cells(s, 6).Value
    base.Cells(PosStr, 7) = wb.Cells(s, 7).Value
    base.Cells(PosStr, 8) = wb.Cells(s, 8).Value
    base.Cells(PosStr, 9) = wb.Cells(s, 9).Value
    base.Cells(PosStr, 10) = wb.Cells(s, 10).Value
    base.Cells(PosStr, 11) = wb.Cells(s, 11).Value
    base.Cells(PosStr, 12) = wb.Cells(s, 12).Value
    base.Cells(PosStr, 13) = wb.Cells(s, 13).Value
Next
'/определяем есть ли вносимый элемент в общей базе если нет то добавляем если есть то редактируем
'определяем есть ли новые элементы в рабочей базе если нет то добавляем если есть то редактируем
 For s = 3 To qLastRow
    wLastRow = wb.Cells(1, 1).CurrentRegion.Rows.Count
    Set WCellFind = wb.Range("A:A").Find(base.Cells(s, 1), , xlValues, xlWhole)
    If Not WCellFind Is Nothing Then PosStr = WCellFind.Row Else PosStr = wLastRow + 1
    wb.Cells(PosStr, 1) = base.Cells(s, 1).Value
    wb.Cells(PosStr, 2) = base.Cells(s, 2).Value
    wb.Cells(PosStr, 3) = base.Cells(s, 3).Value
    wb.Cells(PosStr, 4) = base.Cells(s, 4).Value
    wb.Cells(PosStr, 5) = base.Cells(s, 5).Value
    wb.Cells(PosStr, 6) = base.Cells(s, 6).Value
    wb.Cells(PosStr, 7) = base.Cells(s, 7).Value
    wb.Cells(PosStr, 8) = base.Cells(s, 8).Value
    wb.Cells(PosStr, 9) = base.Cells(s, 9).Value
    wb.Cells(PosStr, 10) = base.Cells(s, 10).Value
    wb.Cells(PosStr, 11) = base.Cells(s, 11).Value
    wb.Cells(PosStr, 12) = base.Cells(s, 12).Value
    wb.Cells(PosStr, 13) = base.Cells(s, 13).Value
Next
Workbooks("БазаРаботТестирования.xlsx").Close SaveChanges:=True

End Sub

Function GetHTML1(ByVal myURL As String) As String
On Error Resume Next
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", myURL, False
        .send
        Do: DoEvents: Loop Until .readyState = 4
        GetHTML1 = .responseText
    End With
End Function
    
Sub Primer3()
Dim myHtml As String, myFile As Object, myTag As Object, myTxt As String
    myHtml = GetHTML1("https://expert.chistov.pro/webinars/537546/")
    Set myFile = CreateObject("HTMLFile")
    myFile.body.innerHTML = myHtml
    Set myTag = myFile.getElementsByTagName("title")
    myTxt = myTag(0).innerText
    MsgBox myTxt
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim a
    If Target.Cells.Count > 1 Then Exit Sub
    If Target = Empty Then Exit Sub
    If Intersect(Target, Range("e2:e150")) Is Nothing Then Exit Sub
    a = Range("E2:E150").Value
    For i = 1 To UBound(a, 1)
    If a(i, 1) = Cells(2, 8) Then Cells(2, 9) = Cells(i + 1, 4).Value Else
    If a(i, 1) = Cells(3, 8) Then Cells(3, 9) = Cells(i + 1, 4).Value
    Next
    If Intersect(Target, Range("d2:d150")) Is Nothing Then Exit Sub
    For i = 1 To UBound(a, 1)
    If a(i, 1) = Cells(2, 8) And Cells(i + 1, 3).Value < Cells(2, 9) Then Cells(i + 1, 3).Value = Cells(2, 9) Else
    If a(i, 1) = Cells(3, 8) And Cells(i + 1, 3).Value < Cells(3, 9) Then Cells(i + 1, 3).Value = Cells(3, 9)
    Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim a() As Integer
Dim i As Integer
    If Target.Cells.Count > 1 Then Exit Sub
    If Target = Empty Then Exit Sub
    If Intersect(Target, Range("e2:e150")) Is Nothing Then Exit Sub

 For i = 2 To 150
    a(i) = .Range("E1").Offset(i)
    Next i

 If Value.a(i) = Cells("h2").Value Then Cells("c" & i).Value = Cells("i2") Else
    If Value.a(i) = Cells("h3").Value Then Cells("c" & i).Value = Cells("i3")
End SubP

tdate = sh.Cells(a, 5)
tdated = Format(tdate, "yyyy-mm-dd")

WMS_DATEd = tdated & "T00:00:00"

tdate = sh.Cells(a, 5)
tdated = CStr(Format(tdate, "yyyy-mm-dd"))

Sub Генератор_запросов_СДТ()
Dim wb, ab As Workbook
Dim sPath As String
Dim sh, sha As Worksheet
'Dim tdate As Date
Set ab = ThisWorkbook
sPath = ThisWorkbook.Worksheets(1).Cells(1, 1).Value
Set wb = Workbooks.Open(sPath & "\" & "СуперФайл", False, True)
Set sh = wb.Worksheets(1)
Set sha = ab.Worksheets(2)
    For a = 2 To sh.UsedRange.Rows.Count
        tdate = sh.Cells(5, a)
        tdated = Format(tdate, "yyyy-mm-dd")
        named = sh.Cells(1, a).Value
        FACT_NUMd = sh.Cells(3, a).Value
        FACT_DATEd = tdated
        WMS_NUMd = sh.Cells(8, a).Value
        WMS_DATEd = tdated & "T00:00:00"
        DOC_NUMd = sh.Cells(11, a).Value
        DOC_DATEd = WMS_DATEd
        DOC_TYPEd = sh.Cells(13, a).Value
        SUB_FROM_CODEd = sh.Cells(20, a).Value
        SUB_TO_CODEd = sh.Cells(21, a).Value
        ITEM_CODEd = sh.Cells(22, a).Value
        QUANTITYd = sh.Cells(23, a).Value
        PACKAGE_NUMd = sh.Cells(24, a).Value
        For b = 1 To 13
            sha.Cells(a, b).Value = named
            sha.Cells(a, b).Value = FACT_NUMd
            sha.Cells(a, b).Value = FACT_DATEd
            sha.Cells(a, b).Value = DOC_NUMd
            sha.Cells(a, b).Value = DOC_DATEd
            sha.Cells(a, b).Value = DOC_TYPEd
            sha.Cells(a, b).Value = SUB_FROM_CODEd
            sha.Cells(a, b).Value = SUB_TO_CODEd
            sha.Cells(a, b).Value = ITEM_CODEd
            sha.Cells(a, b).Value = QUANTITYd
            sha.Cells(a, b).Value = PACKAGE_NUMd
        Next
    Next
End Sub

Sub Äàòà()
Dim wb, ab As Workbook
Dim sWb As String
Dim Cel As Long
Dim ai, bi, ci As Range
Dim sh As Worksheet
Set ab = ActiveWorkbook
  sPath = ThisWorkbook.Worksheets(4).Cells(1, 1).Value
  sWb = ThisWorkbook.Worksheets(4).Cells(1, 2).Value
Set wb = Workbooks.Open(sPath & "\" & sWb, False, True)
Set sh = wb.Worksheets(1)
With sh
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
ai = Range("d15:d" & lLastRow)
bi = Range("k15:k" & lLastRow)
ci = Range("y15:y" & lLastRow)
End With
ab.Worksheets(5).Range("A2:a" & lLastRow - 14) = ai
ab.Worksheets(5).Range("c2:c" & lLastRow - 14) = bi
ab.Worksheets(5).Range("d2:d" & lLastRow - 14) = ci
For Cel = 2 To lLastRow - 14
If Not Cells(Cel, 1) Like "" Then
Cells(Cel, 2) = Barcode.Code_128("A" & Cel)
        End If
If Not Cells(Cel, 3) Like "" Then
Cells(Cel, 5) = Barcode.Code_128("d" & Cel)
        End If
Next Cel
wb.Close False
End Sub

Function Get_Value_From_Close_Book(sPach As String, sWb As String, sShName As String, sAddress As String)
   Dim vData, objCloseBook As Object
   SW = sPach + "\" + sWb
   Set objCloseBook = GetObject(SW)
   vData = objCloseBook.Sheets(sShName).Range(sAddress).Value
   objCloseBook.Close False
   Get_Value_From_Close_Book = vData
End Function

Sub Запрос()
    
Dim Nam As String
Dim vWorkingRange As Range
Nam = "Запрос боксбери" & " " & ActiveSheet.Cells(1, 2).Value
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set vWorkingRange = ActiveWorkbook.Sheets("Лист2").Range("a1:a33")
Workbooks.Add
vWorkingRange.Copy Destination:=ActiveSheet.Cells(1, 1)
ActiveWorkbook.SaveAs Filename:="C:\Users\ABMayorov\Documents\описания\" & Nam & ".txt", FileFormat:= _
xlText, CreateBackup:=False
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Sub Запрос()
    
Dim Nam As String
Nam = "Запрос боксбери" & " " & ActiveSheet.Cells(1, 2).Value
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveWorkbook.Sheets("Лист2").Range("a1:a33").Copy
Workbooks.Add
ActiveSheet.Range("a1:a33").PasteSpecial xlPasteValues
ActiveWorkbook.SaveAs Filename:="C:\Users\ABMayorov\Documents\описания\" & Nam & ".txt", FileFormat:= _
xlText, CreateBackup:=False
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Sub Экспорт()
Dim Nam As String
Nam = InputBox(Prompt:="Укажите имя файла", Title:="Выбираем имя")
                                                         ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value  / преобразование формул в значение
Selection.Copy
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Workbooks.Add
ActiveSheet.Paste
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
ActiveWorkbook.SaveAs Filename:="C:\Users\ABMayorov\Documents\описания\" & Nam & ".txt", FileFormat:= _
xlText, CreateBackup:=False
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Sub macros1()
Dim sh, sb As Worksheet
Set sh = ThisWorkbook.Worksheets(2)
Set sb = GetObject("D:\1ñ\price_1c.xls").Worksheets(1)
For i = 1 To sb.Cells(Rows.Count, 1).End(xlUp).Row
 If sb.cels(i, 3) = "руб." Then sb.Range(Cells(i, 1), Cells(i, 4)).Copy sh.Range("a:d") Else
Next i
End Sub

Sub makros1()
Dim sh, sb As Worksheet
Dim i As Integer
Set sh = ThisWorkbook.Worksheets(2)
Set sb = GetObject("d:\1c\price_1c.xls").Worksheets(1)
With sb.Range("a179:d388,a475:d553").Select.Copy
sh.Range("a:d").past
End With
End Sub