Sub Test()
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim iCell As Range, Rng As Range
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Value = Empty Then Exit Sub
    Set Rng = Union(Range("F:F"), Range("H:H"))
    For Each iCell In Target      'проходим по всем измененным ячейкам
        If Not Intersect(iCell, Rng) Is Nothing Then 'если изменененная ячейка попадает в диапазон A2:A100
            Application.EnableEvents = False
            With iCell.Offset(0, 1)         'вводим в соседнюю справа ячейку дату
                .Value = Now
                '.EntireColumn.AutoFit  'выполняем автоподбор ширины для столбца, чтобы дата умещалась в ячейке
            End With
            Application.EnableEvents = True
        End If
    Next iCell
End Sub

Sub Сoincidence()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim Numbers1 As Variant, Numbers2 As Variant, i As Long
    Dim Found As Range
 
    Set ws1 = ThisWorkbook.Sheets("Лист1")
    Set ws2 = ThisWorkbook.Sheets("Лист2")
    
    'снимаем выделения в столбцах В
    ws1.Columns(2).Interior.Color = xlNone
    ws2.Columns(2).Interior.Color = xlNone
    
    Numbers1 = ws1.Range("B2:B" & ws1.Range("B" & ws1.Rows.Count).End(xlUp).Row).Value
    Numbers2 = ws2.Range("B2:B" & ws2.Range("B" & ws2.Rows.Count).End(xlUp).Row).Value
 
    For i = LBound(Numbers2, 1) To UBound(Numbers2, 1)
        Set Found = ws1.Range("B:B").Find(Numbers2(i, 1))
        If Not Found Is Nothing Then
            Found.Interior.Color = vbYellow
        End If
        Set Found = Nothing
    Next i
 
    For i = LBound(Numbers1, 1) To UBound(Numbers1, 1)
        Set Found = ws2.Range("B:B").Find(Numbers1(i, 1))
        If Not Found Is Nothing Then
            Found.Interior.Color = vbYellow
        End If
        Set Found = Nothing
    Next i
    MsgBox "Конец", vbInformation, ""
End Sub

Dim targetedInfo As MSHTML.IHTMLDOMChildrenCollection

        For i = 0 To targetedInfo.Length - 1
            If i Mod 14 = 0 Then
                rowCounter = rowCounter + 1
                .Cells(rowCounter, 1) = titles(rowCounter - 1).innerText
                .Cells(rowCounter, 2) = targetedInfo.Item(i).innerText
                .Cells(rowCounter, 3) = targetedInfo.Item(i + 8).innerText
            End If
        Next i

Private Sub ComboBox1_Click()
    ActiveCell = Split(Me.ComboBox1)(0)
End Sub

=СУММЕСЛИМН(Покупка!C:C;Покупка!B:B;Продажа!B2)-СУММЕСЛИМН(Покупка!C:C;Покупка!B:B;Продажа!B2;Покупка!H:H;"продана";Покупка!G:G;"<>"&Продажа!K2)

Sub Test()
Dim ArrayToFind As Variant, iItem As Variant, Rng As Range, Sht1 As Worksheet, Sht2 As Worksheet, LastRow As Long

    'запоминаем названия листов в переменные
    Set Sht1 = Worksheets("Лист1")
    Set Sht2 = Worksheets("Лист2")
    
    'очищаем Лист2
    Sht2.UsedRange.Clear
    
    'перечисляем значения для поиска
    ArrayToFind = Array("ФГ", "ФО", "ФЯ 50-я рейка", "ФР", "ФОР", "ФГР")
    
    For Each iItem In ArrayToFind
        'поиск каждого значения на Лист1 в столбцах В:C
        Set Rng = Sht1.Columns("B:C").Find(iItem, , xlFormulas, xlWhole)
        'если нашли
        If Not Rng Is Nothing Then
            'записываем на Лист2
            With Sht2
                LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                .Cells(LastRow, 1) = iItem 'Наименование изделия
                .Cells(LastRow, 2) = Rng.Offset(0, 1) 'длина
                .Cells(LastRow, 3) = Rng.Offset(0, 2) 'ширина
            End With
        End If
    Next iItem
    MsgBox "Данные скопированы!", vbInformation, "Конец"
End Sub

Sheets("Лист1").Copy After:=Sheets(Sheets.Count)

Sub Test()
    Dim sPath As String, Filename As String, Wb As Workbook

    'путь к папке
    sPath = "C:\Отчеты\2021\"
    If Dir(sPath, vbDirectory) = "" Then
        MsgBox "Нет такой директории: " & sPath, vbExclamation, "Внимание"
        Exit Sub
    End If
    'имя первого найденного файла в указанной папке с расширением xlsx, xlsm, xlsb
    Filename = Dir(sPath & "*.xls*")
    'цикл по всем файлам в указанной папке
    Do While Filename <> ""
        'открываем найденный файл
        Set Wb = Workbooks.Open(Filename:=sPath & Filename, UpdateLinks:=False) ', ReadOnly:=True)
            
        'вот тут что-то делаем с открытым нами файлом
            
        'а теперь закрываем файл
        Wb.Close (True) 'True - сохранить и закрыть, False - не сохранять и закрыть
        'поиск следущего файла в папке
        Filename = Dir
    Loop 'конец цикла    
End Sub

Name OldName As NewName

FileCopy OldName, NewName

Sub Макрос1()
    ActiveWindow.TabRatio = 0.5
End Sub

=ТЕКСТ(СЕГОДНЯ();"ММММ")

 =...\\...\ & A1 & \[...]*.xlsx