VBA Makro Inhalte aus einer Exceldateien kopiern und in eine andere einfügen

[Hajo]

Hallo Leute,

ich habe hier ein Problem.

1:
Mit diesem Code öffne ich einen neues Tabellenblatt in meiner Exceldatei (Datenbank) und kann es dann beliebig beschriften (z.B. Kunde1). Nach dem ich es beschriftet habe möchte ich gerne aus einer anderen Exceldatei die sich KNR.xls nennt, die Spalten A bis E komplett Kopieren und  in die Exceldatei (Datenbank) in das neu angelegte Tabellenblatt einfügen.
Ich weiss leider nicht wie ich das Makro weiter schreiben soll.

Sub DATENBANK()

Sheets.Add After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
neuname = InputBox("Neuer Name des Blattes")
ActiveSheet.Name = neuname

2:
Mit diesem folgenden Code  kann ich den Inhalt in Spalte B einer Exceldatei kopieren und mir die Inhalte aus der Spalte A in eine andere Exceldatei hineinfügen.
KNR.xls nennt sich die Exceldatei aus der die informationen in Spalte B stammen. Jede Woche bekomme ich neue KNR.xls Dateien die auch immer KNR heißen.
Speziell soll nun Spalten B aus der KNR Datei kopiert werden.
Die Excel Datei Datenbank ist die Datei in der es hinein eingefügt werden soll.
Speziel in das Tabellenblatt Quelle Spalte A.

Sub DATENBANK()

Dim Quelltab As Worksheet
Dim Zieltab As Worksheet
Dim Zelle As Range
Dim Zaehler As Long
Zaehler = 1
Bereich = "A2:A500"
Set Quelltab = ActiveWorkbook.Worksheets("Quelle")
Set Zieltab = ActiveWorkbook.Worksheets("Output")

Quelltab.Range(Bereich).ClearContents

again:
KNR = InputBox("Bitte KNR Dateiname angeben (z.B. KNR_215)")

On Error GoTo again
Workbooks.Open Filename:="C:\Users\Documents\MaxMustermann\Kunden Ordner\KNR-Datei\" & KNR & ".xls"

Workbooks(KNR & ".xls").Activate
Worksheets("Kundennummer").Select
lz = Worksheets("Kundennummer").Cells(Rows.Count, 2).End(xlUp).Row
Workbooks(KNR & ".xls").Worksheets("Kundennummer").Range("B6:B500").Copy Destination:=Workbooks("DATENBANK.xlsm").Worksheets("Quelle").Range("A2")
Workbooks(KNR & ".xls").Close savechanges = False

For Each Zelle In Quelltab.Range("A1:A500")
Zieltab.Cells(Zaehler, 1) = Zelle
Zaehler = Zaehler + 1

Next Zelle
End Sub

3:
Mit diesem Code hier kann ich aus mehreren Reitern oder Tabellenblätter wenn diese Kunde heißen, alle Inhalte aus diesen Tabellenblättern in ein anderes Tabellenblatt welches sich Archiv nennt hinein kopieren. So weit so gut!
Problem hierbei ist, dass es soweit funktioniert aber komischer weise ein Freiraum von ca. 2000 Zeilen entsteht.
Bedeutet genau: Im Tabellenblatt Archiv sind alle Inhalte aus den Reitern Kunde 1, Kunde 2 usw.

Im Reiter oder auch Tabellenblatt Archivin sind die Inhalte aus den anderen Reitern  in die Spalten A bis R und  von Zeile 1 bis ca. Zeile 1900 eingefügt worden.
Dann sind ca.2000 Zeilen leer und dann ab ca. Zeile 4000 befinden sich die restlichen Inhalte.  Wie bekommt man es hin das alle Informationen  hintereinander einfach eingefügt werden ohne das 2000 leere Zeilen entstehen.

Sub DATENBANK1SA()
Dim ws As Worksheet

Application.ScreenUpdating = False

With Worksheets("Archiv")
.Range(Cells(1, 1), Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 1)).EntireRow.Delete xlShiftUp
End With

For Each ws In ActiveWorkbook.Worksheets


 If Left(ws.Name, 5) = "Kunde" Then

  With Worksheets(ws.Name)
   .Range("A1:R" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy
  End With
 
  With Worksheets("Archiv")
   .Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
  End With

End If

Next ws

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub


vielen Dank für eure Hilfe.

Gruß Hajo