Eine Zelle kopieren und mehrfach untereinander einfügen

[MWCN]

Der Code den ich ändern möchte ist dieser:

Private Sub Suchlauf_Click()
Dim s As String, p As String, r As Long
Dim tw As Workbook, ts As Worksheet
  p = "C:\scan\" 'anpassen, \ am Ende
Set tw = ThisWorkbook
Set ts = tw.Worksheets.Add
  r = 4
 
  s = Dir(p + "*.xlsm", vbNormal)

  While s <> ""
    ts.Cells(r, 1) = s
    Workbooks.Open p + s
Worksheets(" Seite 1 ohne Logo").Range("AD10").Copy
 ts.Cells(r, 1).PasteSpecial Paste:=xlValues
    ActiveWorkbook.Close False
    r = r + 15 'R, Abstand zur naechsten Datei
    s = Dir()

     Wend
 

End Sub



Wichtig ist das nur diese Zeile ("AD10")  15x untereinander kopiert wird , da ich noch ander Bereiche habe die nur 1x kopiert werden!
Ich könnte natürlich das machen :
Worksheets(" Seite 1 ohne Logo").Range("AD10").Copy
 ts.Cells(r + 1, 1).PasteSpecial Paste:=xlValues

aber das dauert sehr sehr lange

[MisterBurns]

Hallo? Bitte ich brauche...? Danke...? Und eine konkrete Frage finde ich hier auch nicht. So nicht.

[MWCN]

Ich hab mir das auch nochmal durchgelesen.
Ich wollte nicht unhöflich sein und entschuldige mich dafür.

Wenn mir jemand helfen kann wäre ich sehr erfreut . Ich lass auch ein Danke da.

[Käpt'n Blaubär]

Hallo,

abgesehen davon, daß ich Deine Antwort in der Gesamtheit als ziemlich "stoffelig" empfinde,
der Teil bleibt immer noch offen

Hallo? Bitte ich brauche...? Danke...? Und eine konkrete Frage finde ich hier auch nicht. So nicht.

[MWCN]

hab es selbst herausgefunden...

kann gelöscht werden