Sub Аршин()
Dim XMLHTTP As Object
Dim URL$, Txt$

URL = "https://fgis.gost.ru/fundmetrology/cm/results/1-34756749"
Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")

XMLHTTP.Open "GET", URL, False
XMLHTTP.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/88.0.4324.182 Safari/537.36"
XMLHTTP.SEND
If XMLHTTP.Status = 200 Then
    Txt = XMLHTTP.responseText
       
    MsgBox Txt 

Else
    MsgBox "Отсутствует соединение..."
End If
Set XMLHTTP = Nothing
End Sub

Function СтандОтклон1(Arr)
    Dim x, aCnt&, aSum#, aAver#, tmp#
    For Each x In Arr
        aSum = aSum + x 'вычисляем сумму элементов массива
        aCnt = aCnt + 1 'вычисляем кол-во элементов
    Next x
    aAver = aSum / aCnt 'среднее значение
    For Each x In Arr
        tmp = tmp + (x - aAver) ^ 2 'вычисляем сумму квадратов разницы элементов массива и среднего значения
    Next x
    СтандОтклон1 = Sqr(tmp / (aCnt * (aCnt - 1))) 'вычисляем СТАНДОТКЛОН.Г()
End Function

Option Explicit

'Л1
Dim ЛЛ1 As Worksheet ' Лист
Dim ТЛ1 As ListObject ' Таблица
Dim СЛ1 As ListRow ' Строка

'Л2
Dim ЛЛ2 As Worksheet ' Лист
Dim ТЛ2 As ListObject ' Таблица
Dim СЛ2 As ListRow ' Строка

Sub Добавить()
    Add.Show
End Sub
Sub СформироватьСписки()
    
    Dim a As Range
    Dim b As Range
    
    Set ЛЛ1 = ThisWorkbook.Worksheets("Л1")
    Set ТЛ1 = ЛЛ1.ListObjects("тб_Мое")
    Set ЛЛ2 = ThisWorkbook.Worksheets("Л2")
    Set ТЛ2 = ЛЛ2.ListObjects("тб_Все")
    ' очистка
    Add.lb_all.Clear
    Add.lb_add.Clear
    Add.lb_all.ColumnWidths = "200,700"
    Add.lb_add.ColumnWidths = "200,700"
    ' заполнение верха Листбокса
    For Each СЛ1 In ТЛ1.ListRows
        Add.lb_all.AddItem СЛ1.Range(1)
        Add.lb_all.List(Add.lb_all.ListCount - 1, 1) = СЛ1.Range(2)
    Next СЛ1
    ------------------------------------------------------------------------------- Тут загвоска
    ' заполенние низа Листбокса
    
    For Each СЛ2 In ТЛ2.ListRows
    Set a = ТЛ2.ListColumns.Item(2).Range.Find(СЛ2.Range(2), , , xlWhole)
       
            For Each СЛ1 In ТЛ1.ListRows
            Set b = ТЛ1.ListColumns.Item(2).Range.Find(СЛ1.Range(2), , , xlWhole)
                If Not a Like b Then   ' если не найден артикуул
                    Add.lb_add.AddItem СЛ2.Range(1)
                    Add.lb_add.List(Add.lb_add.ListCount - 1, 1) = СЛ2.Range(2)
                ElseIf СЛ1.Range(2) Like СЛ2.Range(2) Then
                    Exit For
                End If
            
            Next СЛ1
    Next СЛ2

  ---------------------------------------------------------------------------
End Sub

='D:\[F1.xlsm]СписТов'!B2&" "&'D:\[F1.xlsm]СписТов'!C2&"; "
&'D:\[F1.xlsm]СписТов'!B3&" "&'D:\[F1.xlsm]СписТов'!C3&"; "
&'D:\[F1.xlsm]СписТов'!B6&" "&'D:\[F1.xlsm]СписТов'!C6

=ВРЕМЯ(ВПР(38;E2:G11;2;0);ВПР(E2-2;E2:G11;3;0)-ВРЕМЯ(F2;G2;)

Sub ЗаменаСлов()
    Dim s As String
    Dim avArr, lr As Long
    Dim lLastR As Long
    Dim lToFindCol As Long, lToReplaceCol As Long, lLookAt As Long
lLookAt = 1
lToFindCol = 1
lToReplaceCol = 2
'Получаем с листа Соответствия значения, которые надо заменить в диапазоне
    With ThisWorkbook.Worksheets("Март16")
        lLastR = .Cells(.Rows.Count, 1).End(xlUp).Row
        avArr = .Cells(1, 11).Resize(lLastR, 5)
    End With
'// дальше не выходит задача((((

'заменяем
    For lr = 1 To UBound(avArr, 1)
        s = avArr(lr, lToFindCol)
        If Len(s) Then 'если значение для замены не пустое
            Worksheets("Март16").Columns(16).Replace s, avArr(lr, lToReplaceCol), lLookAt
        End If
    Next lr
End Sub

Sub Extract_Unique()
    Dim vItem, avArr, li As Long
    ReDim avArr(1 To Rows.Count, 1 To 1)
    With New Collection
        On Error Resume Next
        For Each vItem In Range("A2", Cells(Rows.Count, 1).End(xlUp)).Value
            'Cells(Rows.Count, 1).End(xlUp) – определяет последнюю заполненную ячейку в столбце А
            .Add vItem, CStr(vItem)
            If Err = 0 Then
                li = li + 1: avArr(li, 1) = vItem
            Else: Err.Clear
            End If
        Next
    End With
    If li Then [E2].Resize(li).Value = avArr
End Sub

Private Sub UserForm_Initialize() ' заполняем список №составов

Dim lin As Integer
lin = 2

    Do Until База_составы.Cells(lin, 1) = ""
        ComboSostav.AddItem База_составы.Cells(lin, 1).Value
    lin = lin + 1
    Loop

End Sub

Private Sub ComboSostav_Change()

Dim стрк As Integer
стрк = 8 '  сюда надо передать из процедуры UserForm_Initialize строку которая выбрана

ListPesok.Clear
ListSheben.Clear
ListOPGS.Clear
ListDobavka.Clear

ListPesok.AddItem База_составы.Cells(стрк, 2).Value
ListSheben.AddItem База_составы.Cells(стрк, 3).Value
ListOPGS.AddItem База_составы.Cells(стрк, 4).Value
ListDobavka.AddItem База_составы.Cells(стрк, 5).Value

End Sub

Option Explicit

Const НАЧстрока = 2
Const ССЫЛКА = 1
Const КОНцикл = 10

Sub СортировкаЦветовки()
    Dim ДиапазонТаблицы As Range
    Dim myWSheet As Integer
    
myWSheet = Worksheets("Основа").UsedRange.Rows.Count
Set ДиапазонТаблицы = Worksheets("Основа").Range(Cells(НАЧстрока, ССЫЛКА), Cells(myWSheet, КОНцикл))

    With ActiveWorkbook.Worksheets("Основа").Sort
    .SortFields.Clear
    .SortFields.Add(ДиапазонТаблицы, xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(120, 50, 180)
    .SortFields.Add(ДиапазонТаблицы, xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(250, 0, 0)
    .SortFields.Add(ДиапазонТаблицы, xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(100, 50, 0)
    .SortFields.Add(ДиапазонТаблицы, xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(250, 250, 0)
    .SortFields.Add(ДиапазонТаблицы, xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(250, 250, 250)
    .SortFields.Add(ДиапазонТаблицы, xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(0, 180, 250)
    .SortFields.Add(ДиапазонТаблицы, xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(0, 180, 50)
    .SetRange ДиапазонТаблицы
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
    End With
End Sub

Dim stroka1 As Range
Dim stroka2 As Range
Dim strokaSR1 As Range
Dim strokaSR2 As Range
Dim diop1 As Range
Dim diop2 As Range

   Set stroka1 = Worksheets(1).Cells(1, 1)
   Set stroka2 = Worksheets(1).Cells(1, 15)
   Set strokaSR1 = Worksheets(1).Cells(2, 1)
   Set strokaSR2 = Worksheets(1).Cells(2, 5)

  
   diop1 = Range(stroka1, stroka2) ' тут мне VBA ругается
   diop2 = Range(strokaSR1, strokaSR2)

 '/// Мне нужно чтоб к диапазону от stroka1 до stroka2(без прерываний) применялись следующ. свойства
With diop1
            .HorizontalAlignment = xlCenter 'выравнивание по горизотали
            .VerticalAlignment = xlCenter 'выравнивание по вертикали
            .WrapText = False 'перенос текста
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
            .Font.Name = "Times New Roman"
            .Font.FontStyle = "обычный" 'полужирный курсив
            .Font.Size = 14
End With

Sub Сортировка(ByVal ИмяЛиста As String)
    Dim ДиапазонТаблицы As Range
Set ДиапазонТаблицы = Worksheets(ИмяЛиста).Range("O3").CurrentRegion
    With Worksheets(ИмяЛиста).Sort
        .SortFields.Clear
        .SortFields.Add Key:=ДиапазонТаблицы.Columns(16), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=ДиапазонТаблицы.Columns(17), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=ДиапазонТаблицы.Columns(18), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=ДиапазонТаблицы.Columns(15), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange ДиапазонТаблицы '.SetRange ActiveSheet.UsedRange ///.SetRange Range("A1").CurrentRegion
        .Orientation = xlSortRows 'XlSortOrientation (xlSortRows, xlSortColumns, xlTopToBottom)Ориентация сортировки
        .Header = xlNo 'Задает, содержит ли первая строка заголовочную информацию; по умолчанию используется значение xlNo; если нужно, чтобы Excel определил это самостоятельно, укажите xlGuess
        .MatchCase = False 'True - сортировка с учетом регистра букв, False - без учета; для сводных таблиц не используется
        .SortMethod = xlPinYin 'Тип сортировки.Некоторые из этих констант могут быть недоступны в зависимости от поддержки языков например, "Английский (США)"), выбранных или установленных. Может быть одно из следующих значений XlSortMethod: 1)xlStroke.Сортировка по количеству штрихов в каждом знаке. 2)xlPinYin.Порядок сортировки для символов, основанный на фонетике китайского языка
        .Apply '/**//*//**//* тут  выдает ошибку
    End With
End Sub

Sub ЛистСоответствия()
Dim i As Integer
Dim lLastRow As Integer
Dim k As Integer
Dim Наимен As String

'последняя строка в столбце 2 листа 2
lLastRow = Worksheets(2).Cells(Rows.Count, 2).End(xlUp).Row
'последняя строка в столбце 1 листа 1
k = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1

    For i = 3 To lLastRow
    Наимен = Worksheets(2).Cells(i, 2).Value
         If Worksheets(2).Cells(i, 2).Value <> Worksheets(2).Cells(i + 1, 2).Value Then ' доделал)))
             Worksheets(1).Cells(k, 1) = Наимен
          k = k + 1
        End If
    Next i
End Sub

Function фунОКРУГЛ(Число As Single, Optional DecPlaces As Integer = 1) As Single
'Число = CDbl(CStr(Число))
If DecPlaces >= 0 Then
    If Round(Число, DecPlaces) = Число Then фунОКРУГЛ = Число: Exit Function
Else
    If Int(Число * 10 ^ DecPlaces + 0.5) = Число * 10 ^ DecPlaces Then фунОКРУГЛ = Число: Exit Function
End If
фунОКРУГЛ = -Sgn(Число) * Int(-Abs(Число) * 10 ^ DecPlaces) / 10 ^ DecPlaces
End Function

Sub ДобавСтрок()

    Dim строк As Integer
    Dim ОтпускНорм As Single
    Dim ЧислоСтрок As Integer  
    Dim ПрочнМин As Single
    Dim ПрочнСред As Single
    Dim ПрочнТребуем As Single
        
    строк = НАЧАЛcТРОКа
    
' тут операторы условия ......

    ОтпускНорм = Cells(строк, КОЛОНоТПУСК).Value ' допустим что значение возвращено 10,3333333

    Call фунОКРУГЛ(ОтпускНорм) ' тут оно говорит что 10,3
' А ДАЛЬШЕ ЧТО? сразу  записывать в ячейку?Но у меня там не все значения посчитаны!

    ЧислоСтрок = Worksheets(1).Cells(строк, КОЛОНпРОЧ).CurrentRegion.Rows.Count    
    ПрочнМин = WorksheetFunction. Min(Range(Cells(строк - ЧислоСтрок + 1, КОЛОНпРОЧ), Cells(строк, КОЛОНпРОЧ)))  
    ПрочнСред = WorksheetFunction. Average(Range(Cells(строк - ЧислоСтрок + 1, КОЛОНпРОЧ), Cells(строк, КОЛОНпРОЧ)))   
    ПрочнТребуем = 3.99 * Cells(строк - ЧислоСтрок + 1, КОЛОНоТПУСКнОРМ).Value

    ' записываем в ячейки
    Cells(строк - ЧислоСтрок + 1, КОЛОНоТПУСКнОРМ).Value = ОтпускНорм
  
    Cells(строк - ЧислоСтрок + 1, КОЛОНшТУК).Value = ЧислоСтрок
    Cells(строк - ЧислоСтрок + 1, КОЛОНпРОЧмИН).Value = ПрочнМин 
    Cells(строк - ЧислоСтрок + 1, КОЛОНпРОЧсРЕДН).Value = ПрочнСред 
    Cells(строк - ЧислоСтрок + 1, КОЛОНпРОЧтРЕБУЕМ).Value = ПрочнТребуем 
               
                    
End Sub

Sub ДобавСтрок() 
    Dim строк As Integer
    Dim rgn As Range
    строк = НАЧАЛcТРОКа
     
        Do While (Cells(строк, КОЛОНпРОЧ).Value) <> Empty ' пока не пустая ячейка
        '(Not (IsEmpty(Cells(строк, КОЛОНпРОЧ).Value))) //И ЯЧЕЙКА And Cells(строк + 1, КОЛОНПРОЧ)
             
            Do While (Cells(строк + 1, КОЛОНиЗГОТОВ).Value - Cells(строк, КОЛОНиЗГОТОВ).Value) >= 7 Or _
            Cells(строк, КОЛОНнЕДЕЛ).Value > Cells(строк + 1, КОЛОНнЕДЕЛ).Value Or _
            Cells(строк, КОЛОНиЗДЕЛ).Value <> Cells(строк + 1, КОЛОНиЗДЕЛ).Value
                Rows(строк + 1).Insert ' вставляем пустую строку
                Rows(строк + 1).ClearContents ' очищаем значения(пусто делаем)
                 
'Вот тут ЗАГВОСКА.
                Set rgn = Worksheets(1).Cells(строк, КОЛОНпРОЧ).CurrentRegion.Rows.Count 'считает количество строк'
                
                Cells(строк - rgn + 1, КОЛОНкЛАССБЕТ).Value = "B" & Cells(строк, КОЛОНбЕТОН).Value
                
                Cells(строк, КОЛОНоТПУСКНОРМ).Value = Cells(строк, КОЛОНоТПУСК).Value
                 
            строк = строк + 2
            Loop
             
        строк = строк + 1
        Loop
         
End Sub