wyszukiwanie i kopiowanie do nowego arkusza

Witajcie

Mam Arkusz prezentujący w komórkach dane zbiorcze, które pobiera z innych arkuszy gdzie jest cała baza danych.
Każda komórka ma unikalny Adres, który jest w Arkuszu KLUCZ (zmienna KLUCZ_TABELA)

dla zmiennej KLUCZ_TABELA jest jest kilka pozycji w arkuszu

Po wykonaniu poniższego makra wyniki wyszukiwania są kopiowane do nowego Arkusza
Nie jestem autorem tego makra, dostosowałem go do moich potrzeb po poprzedniku ale nie wiem, która część makra powoduje utworzenie nowego arkusza i wstawienie danych.
Prośba o podpowiedź

poniżej makro

Sub WYŚWIETL_SZCZEGÓŁY()

' problem z niewłaściwą lokalizacją po odkryciu arkuszy KLUCZ / BAZA / BAZA2 - przeskakuje na odkrywane pr220203

Dim Name_Month As String
Name_Month = ActiveSheet.Name

Application.ScreenUpdating = True
Sheets("KLUCZ").Visible = True
Sheets("baza").Visible = True
Sheets("baza2").Visible = True

Sheets(Name_Month).Select

On Error GoTo KONIEC
RZĄD = ActiveCell.Row
KOLUMNA = ActiveCell.Column
Select Case ActiveCell
Case Is = Empty
MsgBox ("Dana pozycja jest pusta")
GoTo KONIEC
End Select
ARKUSZ = Range("a1")
Arkusz1 = Range("a2")

MsgBox (Arkusz1)
Sheets("KLUCZ").Select

Cells(RZĄD, KOLUMNA).Select
If IsEmpty(ActiveCell) Then
Sheets("KLUCZ").Select
MsgBox ("Tej pozycji nie można rozwinąć")
Cells(RZĄD, KOLUMNA).Select

Else

KLUCZ_TABELA = ActiveCell.Value
POJEDYNCZEvsSUMA = Cells(RZĄD, 47).Value
Select Case POJEDYNCZEvsSUMA
Case Is = "POJEDYNCZE"
NR_ODDZIAŁU = Cells(2, KOLUMNA).Value
Case Is = "LINIA"
NR_ODDZIAŁU = Cells(4, KOLUMNA).Value
End Select

Sheets("baza").Select
Cells.Find(What:=KLUCZ_TABELA, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True _
, SearchFormat:=True).Activate
ActiveCell.Offset(0, NR_ODDZIAŁU).Select
' Selection.ShowDetail = True
'Call WSTAW_PRZYCISK
Range("A1").Activate
Cells.EntireColumn.AutoFit
Range("a1").Select
End If
KONIEC:
Sheets("KLUCZ").Visible = False 'ukrywa zbędne arkusze
Sheets("baza").Visible = False
Sheets("baza2").Visible = False
'Cells(RZĄD, KOLUMNA).Select
ActiveCell.Range("A1").Select
Application.ScreenUpdating = True
End Sub

Sub WSTAW_PRZYCISK()
Columns("c:c").Select
Selection.NumberFormat = "#,##0"
Range("a1").Select
Columns("b:b").Select
Selection.Font.Bold = True
Columns("c:c").Select
Selection.Font.Bold = True
Columns("g:h").Select
Selection.Font.Bold = True

ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear                                'sortuje wartości
ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("c2") _
    , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.ActiveSheet.Sort
   .SetRange Range("a1:aa1000")
  .Header = xlYes
   .MatchCase = False
   .Orientation = xlTopToBottom
   .SortMethod = xlPinYin
   .Apply

End With

Range("ai1") = Arkusz1

End Sub