Range("A1").TextToColumns _
         Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
         ConsecutiveDelimiter:=False, Tab:=False, _
       Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
     :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
       Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
       ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
      (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
     Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
    33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array(38, 1), Array(39, 1)) _
        , TrailingMinusNumbers:=True

Private Sub Label1_Click()
LName = Label1
TextBox1.Value = LName.Caption

Option Explicit

Public sNowPrinter As String

Sub ChangePrinter()
    sNowPrinter = "Set"
    Dim v, s
    s = Application.ActivePrinter
        v = Application.Dialogs(xlDialogPrinterSetup).Show
     If v = True Then
        sNowPrinter = Application.ActivePrinter
    End If
    Application.ActivePrinter = s
End Sub

Function DoPrint(Optional rr As Range = Nothing, Optional lCopies As Long = 1)
    Dim sActPrinter As String
      If sNowPrinter = "" Or sNowPrinter = "Set" Then
                Call ChangePrinter
               If sNowPrinter = "Set" Then
            If MsgBox("Не выбран принтер для печати. Использовать установленный в качестве активного", vbCritical + vbYesNo) = vbNo Then
                Exit Function
            End If
            sActPrinter = Application.ActivePrinter
        Else
            sActPrinter = sNowPrinter
        End If
    End If
  If rr Is Nothing Then
                ActiveSheet.PrintOut Copies:=lCopies, ActivePrinter:=sActPrinter
    Else
       
        rr.PrintOut Copies:=lCopies, ActivePrinter:=sActPrinter
    End If
  End Function

Private Sub CommandButton1_Click()
    Dim i As Long, j As Long, fst As String, ws As Worksheet, x As Range, a(), b()
    Dim p As String, f As String, wb As Workbook
      Application.ScreenUpdating = False: Set sh = ActiveSheet
    ReDim a(1 To 1000, 1 To 6): b = ListBox1.List
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Укажите рабочую папку": .Show
        If .SelectedItems.Count = 0 Then Exit Sub Else p = .SelectedItems(1) & "\"
    End With
    f = Dir(p & "*.xls*")
    Do While f <> ""
        If p & f <> ThisWorkbook.FullName Then
            Set wb = Workbooks.Open(p & f)
            For i = LBound(b, 1) To UBound(b, 1)
                If b(i, 1) <> "" Then
                    For Each ws In wb.Sheets
                        Set x = ws.UsedRange.Find(b(i, 0), , xlFormulas, xlWhole)
                          
                        If Not x Is Nothing Then
                            fst = x.Address
                               Do
                                j = j + 1
                                a(j, 1) = b(i, 0)
                                a(j, 2) = b(i, 1)
                                a(j, 3) = wb.FullName
                                a(j, 4) = x.Parent.Name
                                a(j, 5) = x.Address
                                a(j, 6) = 1
                                Set x = ws.UsedRange.FindNext(x)
                            Loop While fst <> x.Address
                            End If
                    Next
                End If
            Next
            wb.Close False
        End If
        f = Dir
    Loop
    If a(1, 1) = "" Then
        MsgBox "Нет совпадений!": Exit Sub
    End If
    ListBox2.List = a: Me.Width = 700
End Sub

Public Sub PageNumner()
    Dim VPB As Excel.VPageBreak
    Dim HPB As Excel.HPageBreak
    Dim intVPBC As Integer
    Dim intHPPC As Integer
    Dim lngPage As Long
    
    lngPage = 1
    
    If Activesheet.PageSetup.Order = xlDownThenOver Then
        intHPPC = Activesheet.HPageBreaks.Count + 1
        intVPBC = 1
    Else
        intVPBC = Activesheet.VPageBreaks.Count + 1
        intHPPC = 1
    End If

    For Each VPB In Activesheet.VPageBreaks
        If VPB.Location.Column > ActiveCell.Column Then
            Exit For
        End If
        
        lngPage = lngPage + intHPPC
    Next VPB
    
    For Each HPB In Activesheet.HPageBreaks
        If HPB.Location.Row > ActiveCell.Row Then
            Exit For
        End If
            
        lngPage = lngPage + intVPBC
    Next HPB
    
    MsgBox "Номер страницы активной ячейки = " & lngPage
End Sub