Sub Oem_Value()

    Dim post As Object
 Dim selectItems As Variant

    With CreateObject("InternetExplorer.Application")
        .Visible = True
        .navigate "https://zunamiprotocol.medium.com/followers"
      
        While .readyState < 4: DoEvents: Wend

        For Each post In .Document.getElementsByName("eh ei bz ca cb cc cd ce cf bl ej ek cg el em")
            r = r + 1: Cells(r, 1) = post.innerText
        Next post
        .Quit
    End With

End Sub

 Range("A2:A8").Copy
   Worksheets("Лист1").Range("A2:A8").PasteSpecial Paste:=xlPasteValues
      
        
    Selection.Replace What:=",", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="$", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

Sub Индекс()

 Dim IE As Object
 Dim N As Integer
 
Dim lLastRow As Variant
lLastRow = ThisWorkbook.Worksheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row

Set IE = CreateObject("InternetExplorer.Application")

   IE.Navigate "https://indexphone.ru"

    While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend
    With IE.Document
  
     For N = 2 To Cells(Rows.Count, 2).End(xlUp).Row
     
     .GetElementsByName("search")(0).Value = Cells(N, 2).Value
    SendKeys ("{Enter}")

Sheets("Лист1").Cells(N, 4).Value = IE.Document.getElementsByClassName("post-search-list-postalcode")(0).innerText
  Application.Wait Time:=Now + TimeValue("0:00:10")

 Next
     End With
End Sub

Sub f()

 Dim IE As Object
 Dim N As Integer
 Dim sAnswer As String

' On Error Resume Next
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = False
   IE.Navigate "http://egrul.nalog.ru/index.html"
   
    While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend
    With IE.document
 
     For N = 1 To Cells(Rows.Count, 1).End(xlUp).Row
     
       .GetElementsByName("query")(0).Value = Cells(N, 1).Value
       .getElementById("btnSearch").Click

   Sheets("Лист1").Cells(N, 2).Value = IE.document.getElementById("resultContent").innerText
  
      
 Application.Wait Time:=Now + TimeValue("0:00:10")
 
 Next N
  
    End With

End Sub

Sub f()
 Dim IE As Object
' On Error Resume Next
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = True
   IE.Navigate "http://egrul.nalog.ru/index.html"
   
    While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend
    With IE.Document

        .GetElementsByName("query")(0).Value = Cells(0, 1).Value
       .GetElementById("btnSearch").Click

    Cells(0, 2).Value = IE.Document.getElementsByClassName("div.res-text")(0).innerText
 
'ЗДЕСЬ НИКАК НЕ ВЫХОДИТ НИЧЕГО((
    End With
End Sub

Sub f()

 Dim IE As Object
 On Error Resume Next
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = True
    IE.Navigate "http://egrul.nalog.ru/index.html"
    While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend
    With IE.Document
        .GetElementsByName("query")(0).Value = "7816676808"
       .GetElementsByName("submit")(0).Click

    End With

End Sub

Sub test()
    Dim sh As Shape
    Dim j As Double

    j = 1
    For Each sh In ActiveSheet.Shapes
        sh.Left = j
        j = j + sh.Width
    Next sh
End Sub

Sub график()
Dim i As Long
Dim name As String
For i = 2 To 50

Sheets("Ëèñò7").Select    
 ActiveSheet.Shapes.AddChart2(332, xlLineMarkers).Select
    ActiveChart.SetSourceData Source:=Range(Cells(i, 1), Cells(i, 4))
    ActiveChart.FullSeriesCollection(1).XValues = "=Ëèñò2!$B$1:$D$1"
   ActiveChart.FullSeriesCollection(1).Values = Range(Cells(i, 2), Cells(i, 4))
    ActiveChart.SetSourceData Source:=Range(Cells(i, 1), Cells(i, 4))
    ActiveChart.FullSeriesCollection(1).XValues = "=Ëèñò7!$B$1:$D$1"
     ActiveChart.FullSeriesCollection(1).Select
    ActiveChart.FullSeriesCollection(1).Trendlines.Add
    ActiveChart.FullSeriesCollection(1).Trendlines(1).Select
    Selection.Type = xlLogarithmic
    
     If MsgBox("Продолжить?", vbYesNo, "!!" & Cells(i, 2)) = vbNo Then
  Exit Sub
 End If
Next i
End Sub

If MsgBox("Продолжить?", vbYesNo, "!!" & Cells(i, 2)) = vbNo Then
  Exit Sub
End If

  Range("B2:B31").Select
   Selection.ClearContents
    Next i

Sub test()
    Dim i As Integer, sum As Integer, o As Integer, ch As Integer
     Dim B() As Integer
    summ = 0
    o = 0
      
   n = InputBox("n=")
    ReDim B(n)
    
    
    For i = 0 To n
    If B(i) < 0 Then
    o = o + 1
    sum = sum + B(i)
    End If
    
Next i
'ch = sum / o

 MsgBox "Êîëè÷åñòâî îòðèöàòåëüíûõ ýëåìåíòîâ â ìàññèâå: " & o & vbNewLine & "Èõ ñóììà ðàâíà=" & sum
 'ch = Format(ch, "###0.0")
'MsgBox "×àñòíîå =" & ch
  
 
End Sub

With Sheets("Заказ")
      For Each y In Sheets("Заказ").Range("F1:F250")
      If LCase(y.Text) Like "*кол-во*" Then
             
      
         If IsNumeric(y.Offset(1, 0)) = False Or y.Offset(1, 0) = "" Then
      y.EntireRow.Delete
      End If
          End If
        
         Next y
      End With

Sub Copy2()
Dim currentRow As Integer
Dim sourceCol As Integer
Dim LastRow As Integer
Dim currentRowValue
Dim sourcews As String
sourcews = ActiveSheet.Name 
sourceCol = 6   
RowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row
 
For currentRow = 7 To RowCount  
    currentRowValue = Cells(currentRow, sourceCol).Value
    If Not IsEmpty(currentRowValue) Then
          Rows(currentRow).Copy
          Worksheets("Заказ").Select
          LastRow = Cells(Rows.Count, sourceCol).End(xlUp).Row
          Range(Cells(LastRow + 1, 1), Cells(LastRow + 1, 1)).PasteSpecial Paste:=xlPasteValues
          Worksheets("корпуса").Select
    End If
Next
End Sub

With Application.Workbooks.Item("н и без.xlsx")
   For Each y In wl1.Range("B3:B663")
   rk = .Worksheets("учет по месяцам").Cells(Rows.Count, 3).End(xlUp).Row
    If .Worksheets("учет по месяцам").Columns(2).Find(y) Is Nothing Then
                .Worksheets("учет по месяцам").Cells(rk + 1, 2).Value = y
                    .Worksheets("учет по месяцам").Cells(rk + 1, 3).Value = y.Offset(, 1)
                    
                    .Worksheets("учет по месяцам").Cells(rk + 1, 4).Value = y.Offset(, 2)
                    .Worksheets("учет по месяцам").Cells(rk + 1, 5).Value = y.Offset(, 3)
                   .Worksheets("учет по месяцам").Cells(rk + 1, 6).Value = y.Offset(, 4)
                   .Worksheets("учет по месяцам").Cells(rk + 1, 11).Value = "Б"
                   End If
           
        Next y
 End With

End Sub

Sub example2()
 Dim x As Range
    Dim wb0 As Workbook
    Dim wl0 As Worksheet
    Application.ScreenUpdating = False
    Set wb0 = ThisWorkbook
    Set wl0 = wb0.ActiveSheet
    wb0.Activate


 With Workbooks.Open("C:\Учет.xlsx")


    For Each x In wl0.UsedRange.Cells
            If LCase(x.Value) = "*окна*" Then
            
                rk = .Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row
                If Not .Worksheets("Лист1").Columns(3).Find(x.Offset(, -2)) Is Nothing Then
                    
                End If
            End If
        Next x
 
    End With
End Sub
  

Sub example2()
    Dim x As Range
    Dim wb0 As Workbook
    Dim wl0 As Worksheet
    Application.ScreenUpdating = False
    Set wb0 = ThisWorkbook
    Set wl0 = wb0.ActiveSheet
    wb0.Activate
    With Workbooks.Open("C:\Учет .xlsx")
        For Each x In wl0.UsedRange.Cells
            If LCase(x.Value) Like "*окна*" Then
                rk = .Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row
                If Not .Worksheets("Лист1").Columns(3).Find(x.Offset(, -2), , , 1) Is Nothing Then
                    .Worksheets("Лист1").Cells(rk + 1, 3).Value = x.Offset(, -2)
                End If
            End If
        Next x

    End With   
End Sub

Sub example2()
Dim x As Range

Dim wb As Workbook, wb0 As Workbook
Dim wl As Worksheet, wl0 As Worksheet
Application.ScreenUpdating = False
Set wb0 = ThisWorkbook
Set wl0 = wb0.ActiveSheet
Set wb = Workbooks.Open(Filename:="C:\Учет.xlsx")
Set wl = wb.Worksheets("Лист1")

    wb0.Activate


For Each x In wl0.UsedRange.Cells
If LCase(x.Value) Like "*мост*" Then


With Application.Workbooks.Item("Учет РОДС.xlsx")
rk = Workbooks("Учет РОДС.xlsx").Worksheets("Лист1").Columns("C:C").Rows(65536).End(xlUp).Row + 1
           If Sheets("Лист1").Range("C:C").Find(What:=x.Offset(0, -2), LookAt:=xlWhole)  Then
               wl.Cells(rk + 1, 3).Value = x.offcet(0, -2)
              End If
            End With
        End If
    Next x
End Sub

Sub example2()
Dim x As Range

Application.ScreenUpdating = False
Workbooks.Open Filename:="C:\Users\Documents\Учет.xlsx"
For Each x In ActiveSheet.UsedRange.Cells
If LCase(x.Value) Like "*Роллеты*" Then

rk = Workbooks("Учет.xlsx").Worksheets("Лист1").Columns("C:C").Rows(65536).End(xlUp).Row + 1

        
 Sheets("Лист1").Cells(rk, 3).Value = x.offcet(0,-1)
 
End If
Next x



End Sub

Sub example2()
Dim x As Range
For Each x In ActiveSheet.UsedRange.Cells
If x.Value = "сентябрь" Then
x.Interior.ColorIndex = 5
End If
Next x
End Sub

Sub Ut()

Dim lLastRow As Long
   Dim rFndRng As Range
    Set rFndRng = Columns("D:D").Find("*родс*", , xlValues, xlWhole)
    If rFndRng Is Nothing Then
        MsgBox "Нет"
    Else
       
  
      
       Workbooks.Open Filename:="C:\Users\Documents\Учет РОДС.xlsx"
       
     
  If Workbooks("Учет.xlsx").Worksheets("учет по месяцам").rFndRng.Offset(, 1) <> Workbooks("Учет РОДС.xlsx").Worksheets("Лист1").Columns("C:C") Then
     rk = Workbooks("Учет РОДС.xlsx").Worksheets("Лист1").Columns("C:C").Rows(65536).End(xlUp).Row + 1
     Sheets("Лист1").Cells(rk, 3) = rFndRng.Offset(, 1).Value
       
        End If
    End If
   End Sub