Restart Sub when Finished

I'm copying info from about 2000 Sheets in around 200 Workbooks, and lazy as I am, rather that pressing 2 keys (I'm using ALT+1 to run the macro at the moment) to start the process for each sheet I'd like it to run the Sub then restart.
The code starts in the worksheet(W1) where I copy the info from, copys it, pastes it in the other workbook(W2), closes W1 and opens the next W1 from a list of links in W2.
Then stops.
how can I make the whole process start again automatically?

Here's the code (messy as it is..)

 

Sub Copy_Rech()
'
' Copy_Rech Makro
'
' Tastenkombination: Strg+b
'
Dim IB As String
Dim IB2 As String
Dim Wkbk As Workbook
Dim RechWkbk As Workbook
Dim Rechrange As String
Dim Rechnung As String
Set Wkbk = ActiveWorkbook
Set RechWkbk = Workbooks("2014 Hyperlinks.xlsx")
Dim FindName As Range
Dim FindEnd As Range
Dim ManStart As Range
Dim ManEnd As Range
Dim CopyRange As Range

Workbooks("2014 Hyperlinks.xlsx").Activate
IB = Application.WorksheetFunction.Index(Range("J1:J200"), Application.WorksheetFunction.Match(ActiveCell.Offset(0, -37), Range("I1:I200"), 0))
If MsgBox("Sheet=" & IB, vbYesNo) = vbYes Then
    Sheets(IB).Select
    Else
    IB2 = Application.InputBox("Sheet=", Type:=2)
    If MsgBox("Sheet=" & IB2, vbYesNo) = vbYes Then
    Sheets(IB2).Select
    End If
End If
Application.ScreenUpdating = False
Wkbk.Activate
On Error GoTo FindErr:
Set FindName = Range("A:A").Find(What:="Name").Offset(2)
Set FindEnd = Range("C:E").Find(What:="Place2").Offset(-2)
Set CopyRange = Range(FindName.EntireRow, FindEnd.EntireRow)

Copy1:
CopyRange.Copy

RechWkbk.Activate
Range("G" & Rows.Count).End(xlUp).Offset(1).Select
ActiveCell.EntireRow.Select
ActiveSheet.Paste
  Application.CutCopyMode = False
Range("G" & Rows.Count).End(xlUp).Offset(1).Select


Wkbk.Activate
Wkbk.Close False
Workbooks("2014 Hyperlinks.xlsx").Activate
Sheets("Übersicht").Activate
If ActiveCell.Offset(0, 1).Value = 0 Then
ActiveCell.EntireRow.Hidden = True
Range("BC" & (ActiveCell.Row)).Offset(1).Select
Else
ActiveCell.Offset(0, 1).Select
End If
    
Rechnung = Range("N" & (ActiveCell.Row))
 Rechrange = ActiveCell.Offset(0, -37)
    
    Workbooks.Open fileName:= _
       Range("o" & (ActiveCell.Row))
    ActiveWindow.Visible = False
    Windows(Rechnung).Visible = True
        Application.Goto Reference:=Worksheets(Rechrange).Range("G20")
        
Application.ScreenUpdating = True
Exit Sub


FindErr:
Set ManStart = Application.InputBox("Where to Start?", Type:=8)
Set ManEnd = Application.InputBox("Where to stop?", Type:=8)
Set CopyRange = Range(ManStart.EntireRow, ManEnd.EntireRow)
Resume Copy1
End Sub