Vielen Dank für die Antwort Flotter Feger.

Habe hier mal den Code reingepackt, wo denkst du könnte ich einen bereits vergebenen Namen zugeordnet haben? 

Vielen dank im Voraus und beste Grüße

Sub loeschen()


Dim wb As Workbook
Set wb = ActiveWorkbook
Dim ws As Worksheet
Set ws = Tabelle1
Dim ws2 As Worksheet
Set ws2 = Tabelle2


Dim wb2 As Workbook

Tabelle1.UsedRange.ClearContents
'On Error GoTo Errorhandler2
Tabelle1.UsedRange.ClearContents
Tabelle1.UsedRange.ClearFormats
Tabelle1.UsedRange.ClearFormats

'Errorhandler2:

On Error Resume Next
Tabelle2.ShowAllData
Tabelle2.UsedRange.Copy ws.Cells(1, 1)

Tabelle2.UsedRange.ClearContents
Tabelle2.UsedRange.ClearContents
Tabelle2.UsedRange.ClearFormats
Tabelle2.UsedRange.ClearFormats

'On Error GoTo Errorhandler
For i = 1 To 12
    If ws.Cells(2, i) = "Part#_new" Then
Tabelle1.Cells.Replace What:="Part#_new", Replacement:="Part#", SearchOrder:=xlByColumns, MatchCase:=True
Tabelle1.Cells.Replace What:="Description_new", Replacement:="Description", SearchOrder:=xlByColumns, MatchCase:=True
Tabelle1.Cells.Replace What:="Royalities_new", Replacement:="Royalities", SearchOrder:=xlByColumns, MatchCase:=True
    End If
Next

'Errorhandler:
Dim myfilenamepicker As FileDialog
Set myfilenamepicker = Application.FileDialog(msoFileDialogFilePicker) ' Filedialog ermöglicht dialog, msoFileDialogFolderPicker ermöglicht es einen Ordner auszuwählen
myfilenamepicker.InitialFileName = "G:\Departments\Reporting Analyzing\_Downloads"
myfilenamepicker.Show
If myfilenamepicker.SelectedItems.Count <> 0 Then
myfilename = myfilenamepicker.SelectedItems(1)

Set wb2 = ThisWorkbook.Application.Workbooks.Open(myfilename)
Debug.Print (myfilename)
Dim ws3 As Worksheet
Set ws3 = wb2.Worksheets(TabellenIndex(wb2, "Tabelle1")) 'Wieso kann ich hier nicht die Funktion nutzen?
On Error Resume Next
ws3.ShowAllData
ws3.UsedRange.Copy ws2.Cells(1, 1)
Debug.Print (ws3.Name)

End If


wb2.Close SaveChanges:=False

Call kopiereneinfügengundh
Call in_analysis_bom_pasten


End Sub
Function TabellenIndex(ByRef wkb As Workbook, ByVal strCodename As String) As Integer
'Set wkb = ThisWorkbook.Application.Workbooks.Open("G:\Departments\Procurement\T-BAR\.xls")
'
Dim wks As Worksheet
For Each wks In wkb.Worksheets
  If wks.CodeName = strCodename Then
    TabellenIndex = wks.Index
    Exit Function
  End If
Next wks
End Function


Sub kopiereneinfügengundh()

Dim ws As Worksheet
Set ws = Tabelle1
Dim wsnew As Worksheet
Set wsnew = Tabelle2

Dim lrow As Integer
Dim Oldcell As Range
Dim arrCriteria() As String
Dim lngCriteriaCount As Long
Dim element As Variant

Dim lrownew As Integer
Dim NewCell As Range


lngCriteriaCount = 2

ReDim arrCriteria(0 To lngCriteriaCount - 1)
arrCriteria(0) = "Description"
arrCriteria(1) = "Part#"

Tabelle4.UsedRange.ClearContents
Tabelle4.UsedRange.ClearFormats

lrow = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
lrownew = wsnew.UsedRange.SpecialCells(xlCellTypeLastCell).Row
lrowpaste = Tabelle1.UsedRange.SpecialCells(xlCellTypeLastCell).Row


Debug.Print (lrowpaste)

If ws.AutoFilterMode = False Then
ws.Rows(2).AutoFilter
End If

If wsnew.AutoFilterMode = False Then
wsnew.Rows(2).AutoFilter
End If


For i = 1 To 30
    If ws.Cells(2, i).Value = "Typ" Then
    ws.Range(ws.Cells(2, i), ws.Cells(lrow, i)).AutoFilter Field:=i, Criteria1:="KT"
    End If
Next

For i = 1 To 30
    If ws.Cells(2, i).Value = "Quantity" Then
    ws.Range(ws.Cells(2, i), ws.Cells(lrow, i)).AutoFilter Field:=i, Criteria1:="<>0"
    End If
Next

For i = 1 To 30
    If wsnew.Cells(2, i).Value = "Typ" Then
    wsnew.Range(wsnew.Cells(2, i), wsnew.Cells(lrow, i)).AutoFilter Field:=i, Criteria1:="KT"
    End If
Next

For i = 1 To 30
    If wsnew.Cells(2, i).Value = "Quantity" Then
    wsnew.Range(wsnew.Cells(2, i), wsnew.Cells(lrow, i)).AutoFilter Field:=i, Criteria1:="<>0"
    End If
Next



For i = 1 To 10
Set Oldcell = ws.Cells(2, i)
    For Each element In arrCriteria()
        If element = ws.Cells(2, i).Value Then
        ws.Range(ws.Cells(2, i), ws.Cells(lrow, i)).SpecialCells(xlCellTypeVisible).Copy Tabelle4.Cells(1, i) 'Muss hier "Category" schreiben und geht nicht in Abhängigkeit eines Arrays, wieso?
        End If
    Next
Next



For i = 1 To 10
Set NewCell = wsnew.Cells(2, i)
    For Each element In arrCriteria()
        If element = wsnew.Cells(2, i).Value Then
            wsnew.Range(wsnew.Cells(3, i), wsnew.Cells(lrownew, i)).SpecialCells(xlCellTypeVisible).Copy Tabelle4.Cells(lrowpaste, i) 'Problem: Lrowpaste nimmt die lrow, bevor Daten aus Tabelle1 eingefügt werden
        End If
    Next
Next



' Aus dem range in anderen tabelle Fund G rausziehen als Variable
    lrow4 = Tabelle4.UsedRange.SpecialCells(xlCellTypeLastCell).Row
    Tabelle4.Range(Tabelle4.Cells(1, 6), Tabelle4.Cells(lrow4, 7)).RemoveDuplicates Columns:=2, Header:=xlYes 'das sollte noch in Abhängigkeit von i gehen, irgendwie oben einbauen oder schauen ob es sowas wie first und last column gibt, dann vorher Blatt clearen

'Alternative statt mit dem For...each zu arbeiten
'Dim i As Long, ialngIndex As Long
''...
'For i = 1 To 10
'   '...
'    For ialngIndex = 0 To UBound(arrCriteria)
'        If ws.Cells(2, i).Value = arrCriteria(ialngIndex) Then
'            ws.Range(ws.Cells(2, i), ws.Cells(lrow, i)).Copy Tabelle4.Cells(10, 10) '10,10 zu was Sinnvollem anpassen
'        End If
'    Next
'Next
''...

End Sub
Sub in_analysis_bom_pasten()

Dim ws1 As Worksheet
Set ws1 = Tabelle4
Dim wsanalysis As Worksheet
Set wsanalysis = Tabelle3

Dim lrow As Integer

Dim arrCriteria() As String
Dim lngCriteriaCount As Long

lngCriteriaCount = 3

ReDim arrCriteria(0 To lngCriteriaCount - 1)
arrCriteria(0) = "Category"
arrCriteria(1) = "Part#"
arrCriteria(2) = "Description"


'!!!!! In Allen tabellen in Analysis BOM noch in Zeile 17 die Spaltenbeschriften (Spalte B + C) machen, damit For-Schleife zieht


If Tabelle3.AutoFilterMode = True Then
On Error GoTo Errorhandler:
    Tabelle3.ShowAllData
  End If

Errorhandler:

lrow1 = wsanalysis.UsedRange.SpecialCells(xlCellTypeLastCell).Row

For i = 1 To 30
    For Each element In arrCriteria()
        If wsanalysis.Cells(17, i) = element Then
            wsanalysis.Range(wsanalysis.Cells(18, i), wsanalysis.Cells(lrow1, i)).Clear
        End If
    Next
Next

For i = 1 To 30
    For j = 1 To 10
        If wsanalysis.Cells(17, j) = ws1.Cells(1, i).Value Then 'Royalties wurden falsch geschrieben
          ws1.Range(ws1.Cells(2, i), ws1.Cells(lrow1, i)).SpecialCells(xlCellTypeVisible).Copy wsanalysis.Cells(18, j) 'Pasten noch machen wsbol.einsunterroyalties (Range("G4") G = j 4 lastrow mit offset von j

        End If
    Next
Next

End Sub