Private Sub CommandButton1_Click()
Dim const2&, const3&, perem1, const4&
Dim sh As Worksheet
  const1 = Sheets("Лист4").Range("B1").Value
  const2 = Sheets("Лист4").Cells(Rows.Count, 1).End(xlUp).Row
  Sheets("Лист4").Range("A1:A" & const2).ClearContents
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> "Лист4" Then
         shi_ = sh.Name
          const3 = Sheets(shi_).Cells(Rows.Count, 1).End(xlUp).Row
           Set perem = Sheets(shi_).Range("A1:A" & const3).Find(const1, , xlValues, xlWhole, xlByRows)
                If IsNumeric(perem) Then
                    perem1 = perem.Row
                    const4 = Sheets("Лист4").Cells(Rows.Count, 1).End(xlUp).Row
                    Sheets(shi_).Range("B" & perem1 & ":C" & perem1).Copy
                      If const4 = 1 Then
                            Sheets("Лист4").Range("A" & const4).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                            :=False, Transpose:=True
                    Else
                            Sheets("Лист4").Range("A" & const4 + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                            :=False, Transpose:=True
                      End If
                End If
        End If
    Next sh
End Sub