Function DI(text As String) As String
    Set myRegExp = CreateObject("VBScript.RegExp")
    With myRegExp
         .Pattern = "\d{10}"
         .Global = True
         .MultiLine = True
         .IgnoreCase = False
    End With
    DI = Trim(myRegExp.Replace(text, ""))
End Function

Sub Федресурс()
   Dim IE As Object
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = True
    IE.Navigate "https://www.fedresurs.ru/"
    While IE.Busy Or (IE.readyState <> 4): DoEvents: Wend
    With IE.document
        .getElementsByName("searchString")(0).Value = Range("a3")
        .getElementsByTagName("button")(0).Click
    End With
            IE.Navigate "https://www.fedresurs.ru/search/entity?code=" & Range("a3") & ""
End Sub

Private Sub Test()
On Error Resume Next
    Set IE = CreateObject("InternetExplorer.Application")
    With IE
        .Visible = True
        .Navigate "http://www.planetaexcel.ru/"
        Do While .Busy Or .readyState <> 4
            DoEvents
        Loop
      Set Login1_Us = .document.getElementsByTagName("Input")
      Login1_Us("USER_LOGIN").Value = "Djinn"
        Set Login1_Password = .document.getElementsByTagName("Input")
        Login1_Password("USER_PASSWORD").Value = "*******"
        Set LoginButton = .document.getElementsByTagName("Input")
        LoginButton("Login").Click
        Do While .Busy Or .readyState <> 4
            DoEvents
        Loop
    End With
    Set IE = Nothing
End Sub

Private Sub App_WindowActivate(ByVal Wb As Workbook, ByVal Wn As Window)
    ColumnName = "acc_n": On Error Resume Next: Err.Clear
    Range("1:1").Find(ColumnName).EntireColumn.NumberFormat = "0"
End Sub

Sub test()
   
    a = Range("D1").Value
    If [A1:A97].Find("*" & a & "*", , , xlPart) Is Nothing Then
        MsgBox "1"
    Else
        MsgBox "2"
    End If
End Sub

Sub SmartFillDown()
    Dim rng As Range, n As Long
    rng2 = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set rng = ActiveCell.CurrentRegion
    If rng.Cells.Count > 1 Then
        n = rng.Cells(1).Row + rng2 - ActiveCell.Row
        On Error Resume Next
        For Each cell In Selection
        cell.AutoFill Destination:=cell.Resize(n, 1), Type:=xlFillValues
        Next
    End If
End Sub

Sub AO()
    ColumnName = "acc_n": On Error Resume Next: Err.Clear
    Range("1:1").Find(ColumnName).EntireColumn.NumberFormat = "0"
End Sub