ws2.Cells(lastRow2 + i, 1).Value = uniqueNames.Item(i)

ws2.Cells(lastRow2 + 1, 1).Value = uniqueNames.Item(i)
lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row

Sheets(1).Cells(1, 1).Value = html.getElementsByClassName("price")(1).innerText

Sheets(1).Cells(1, 1).Value = html.getElementsByClassName("price")(2).innerText

If Target.Address <> "$E$1" Then Exit Sub  
If Target <> "День" Then Exit Sub
[d1] = Evaluate("b1-c1")

If Target.Address = "$E$1" and Target = "День" Then [d1] = Evaluate("b1-c1")

=ЕСЛИ(ИЛИ(ЛЕВСИМВ(Q2;1)=" ";КОДСИМВ(Q2)=160);ПРАВСИМВ(Q2;ДЛСТР(Q2)-1);Q2)

=ЕСЛИОШИБКА(ЕСЛИ(ПОИСК("N";B1)>0;"№2";"");"")

Sub Пример1()
Application.DisplayAlerts = False
Set CalledByShape = ActiveSheet.Shapes(Application.Caller)
  S1 = CalledByShape.OLEFormat.Object.Text
  Path_pap = mid(ThisWorkbook.Path,1,instrrev(ThisWorkbook.Path,"\"))
 
Call ReadFileNames(Path_pap, S1)
    
ThisWorkbook.Close Savechanges:=True
     
Application.DisplayAlerts = False
End Sub

Sub ReadFileNames(FolderPath, filenamefind)
    On Error Resume Next
    Set fso = CreateObject("scripting.filesystemobject")
    Set curfold = fso.GetFolder(FolderPath)
    If Not curfold Is Nothing Then
        For Each fil In curfold.Files
            If fil.Name Like "*" & filenamefind & ".xls*" Then
                Workbooks.Open curfold & "\" & fil.Name
                Exit Sub
            End If
        Next
        For Each sfol In curfold.SubFolders
            ReadFileNames sfol.Path, filenamefind
        Next
        Set fil = Nothing: Set curfold = Nothing: Set fso = Nothing:
    End If
End Sub

=СЦЕПИТЬ("№";--ЕСЛИОШИБКА(ПОИСК("M";B1)>0;2))

Sub Пример1()
Application.DisplayAlerts = False
Set CalledByShape = ActiveSheet.Shapes(Application.Caller)
  S1 = CalledByShape.OLEFormat.Object.Text
  Path_pap = mid(ThisWorkbook.Path,1,instrrev(ThisWorkbook.Path,"\"))

Workbooks.Open Path_pap & S1 & "\" & S1 & ".xls"
   
ThisWorkbook.Close Savechanges:=True
    
Application.DisplayAlerts = False
End Sub

=--ЕСЛИОШИБКА(ПОИСК("M";B1)>0;2)

Dim CalledByShape As Shape
    Set CalledByShape = ActiveSheet.Shapes(Application.Caller)
    MsgBox CalledByShape.OLEFormat.Object.Text

Sub Копирование()
AllRecs = Sheets("1").Cells(Sheets("1").Rows.Count, 3).End(xlUp).Row
cAllRecs = Sheets("2").Cells(Sheets("2").Rows.Count, 2).End(xlUp).Row
For CurRec = 1 To AllRecs
For cRecs = 2 To cAllRecs
    If Sheets("1").Cells(CurRec, 3) = Sheets("2").Cells(cRecs, 2) Then 'сверка критериев если Они равны то:
    'в этой строке указанным ячейкам присвоить значения из листа 1
    Sheets("1").Cells(CurRec, 6) = Sheets("2").Cells(cRecs, 3)
    Sheets("1").Cells(CurRec, 7) = Sheets("2").Cells(cRecs, 4)
    End If 'конец условия
Next cRecs 'следующая строка на Листе2
'После  окончания проверки на Листе 2 возвращаемся на Лист 1 за следующей суммой критериев:
Next CurRec
End Sub

Sub копирование_табл_из_тела_письма()
    otvet = MsgBox("Выполнить проверку корреспонденции?", vbQuestion + vbYesNoCancel, "Запуск процесса...")
    If Not otvet = vbYes Then Exit Sub
    
    Dim objOutlook As Object, objNameSpace As Object, objFoldersAkk As Object
    Dim objFolder As Object, objMail As Object, oItems As Object
    Dim xDoc As Object
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application") 'активируем Outlook
    Err.Clear
    If objOutlook Is Nothing Then Set objOutlook = CreateObject("Outlook.Application") 'если не открыт, то открываем Outlook
    ' проверка на наличие установленного Outlook
    If Err.Number <> 0 Then
        Set objOutlook = Nothing
        Application.ScreenUpdating = True
        MsgBox "Внимание! Проверьте правильность установки Outlook!", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    Set objNameSpace = objOutlook.GetNamespace("MAPI") ' объявляем переменную для работы с папками Outlook
    ' обновляем почту в Outlook
    For I = 1 To objNameSpace.SyncObjects.Count
        objNameSpace.SyncObjects.Item(I).Start
    Next
    Application.Wait (Now + TimeValue("0:00:05")) ' пауза в выполнении кода для обновления папок Outlook
    ' определяем для обработки папки в аккаунте Outlook
    
    vib_mail_adr = "test@test.ru" ' аккаунт в Outlook
    
    Set objFoldersAkk = objNameSpace.Folders(vib_mail_adr).Folders
    Set objFolder = objNameSpace.Folders(vib_mail_adr).Folders("Входящие") ' папка в аккаунте
    ' просмотр писем в папке
    Set oItems = objFolder.Items: kol_ma_frm = oItems.Count
    For ma = kol_ma_frm To 1 Step -1
        Set objMail = oItems.Item(ma) ' письмо из папки
        znach_subj = Trim(CStr(objMail.Subject)) ' тема письма
        znach_date = Left(objMail.CreationTime, 10) ' дата письма

        find_subj = "Тест" ' значение темы для поиска
        
        If znach_subj = find_subj and znach_date=cstr(cdate(date)) Then
            kon_y = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
            ActiveSheet.Range("A" & CStr(kon_y)).Select
            Set xDoc = objMail.GetInspector.WordEditor
            For I = 1 To xDoc.Tables.Count
                Set xTable = xDoc.Tables(I)
                xTable.Range.Copy
                ActiveSheet.Paste
                kon_y = kon_y + xTable.Rows.Count + 1
                ActiveSheet.Range("A" & CStr(kon_y)).Select
            Next
        End If
    Next
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "Проверка корреспонденции выполнена.", vbInformation
End Sub