LOL - wenigstens zeigt der Link, wo eine vernünftige Vorlage

Step 1 - wozu ein Makro, wenn es ein Mausklick auch regelt?

Step 2 - ohne die Vorlage hättest du jetzt x Makro-Vorschläge zum Verschrotten deine Mappe

Step 3 - was soll ein Programmierer mit so einem Chaos?

Bereinige erst einmal, was du nicht benötigst. Wie überhaupt, sollte man(n) erst mit Code-Texten
beginnen, wenn die Vorlage in sich schlüssig und fertig.
Wie Werner schon in anderen Beiträgen explizit erläutert, vermeide solche verbundenen Zellen, u.a.

Dennoch als Momentaufnahme, den zwischenzeitlich hattu ja sicher schon x-mal umgebaut!

Option Explicit

Sub Step2_Prüfe_Lösche()
Dim oWsh As Worksheet, Sh As Worksheet

'das mit dem Filter lassen wir einmal

Application.DisplayAlerts = False

   Set oWsh = Sheets("Temp")
   For Each Sh In ThisWorkbook.Sheets
      If Sh.Name <> oWsh.Name Then
         If Sh.Visible = -1 Then
            If Not oWsh.Columns(4).Cells.Find(Sh.Name, LookIn:=xlValues) Is Nothing Then
               If MsgBox("Arbeitsblatt: " & Sh.Name & " löschen?", vbQuestion + vbYesNo) = vbYes Then Sh.Delete
            End If
         End If
      End If
   Next Sh

Application.DisplayAlerts = False

End Sub


Sub Step3_AutoFilterCopy()
Dim wSh As Worksheet, wSto As Worksheet
Dim strFiltered As Variant, ShIndex As Variant
Dim Rng As Range
Dim arrF() As Variant, x


   Set wSh = ActiveSheet
   strFiltered = FilterProper(wSh, 4)
   If Len(strFiltered) Then
      ShIndex = FilteredSheet(strFiltered)
      If ShIndex = 0 Then Exit Sub
   End If
   
   Set wSto = Sheets(ShIndex)
   
   Set Rng = ClearToDo(wSto)
   If Rng Is Nothing Then Exit Sub

On Error GoTo errh
   arrF = MakeArea(wSh, strFiltered)
   With wSto
      For x = LBound(arrF, 1) To UBound(arrF, 1)
         Rng.Offset(x).Value = arrF(x, 1)
         Rng.Offset(x, 1).Value = arrF(x, 2)
         Rng.Offset(x, 8).Value = arrF(x, 3)
         Rng.Offset(x, 9).Value = arrF(x, 4)
         Rng.Offset(x, 10).Value = arrF(x, 5)
         Rng.Offset(x, 11).Value = arrF(x, 6)
      Next x
   End With
On Error GoTo 0

errh:
End Sub

Private Function MakeArea(Sh As Worksheet, ToDo As Variant) As Variant
Dim RngF As Range, RngA As Range, RngR As Range
Dim rwCnt As Long
Dim arrTo() As Variant, x

   With Sh
      Set RngF = .AutoFilter.Range
      Set RngF = RngF.SpecialCells(xlCellTypeVisible)
      
      For Each RngA In RngF.Areas
         For Each RngR In RngA.Rows
            rwCnt = rwCnt + 1
         Next RngR
      Next RngA
      
      ReDim arrTo(1 To rwCnt - 1, 6)
      
      For Each RngA In RngF.Areas
         For Each RngR In RngA.Rows
            If RngR.Row <> 1 Then
               x = x + 1
               arrTo(x, 1) = RngR.Cells(3).Value
               arrTo(x, 2) = RngR.Cells(5).Value
               arrTo(x, 3) = RngR.Cells(1).Value
               arrTo(x, 4) = RngR.Cells(2).Value
               arrTo(x, 5) = RngR.Cells(6).Value
               arrTo(x, 6) = RngR.Cells(7).Value
            End If
         Next RngR
      Next RngA
      
   End With
   
   MakeArea = arrTo

End Function

Private Function ClearToDo(Sh As Worksheet) As Range
Dim Cfirst As Range, Cend As Range
   On Error Resume Next
   With Sh
      Set Cfirst = .Cells.Find("Artikelnummer", LookIn:=xlValues)
      Set Cend = Cfirst.CurrentRegion
      If Cend.Rows.Count > 1 Then
         Set Cend = Cend.Offset(1).Resize(Cend.Rows.Count - 1)
         Cend.ClearContents
      End If
      Set ClearToDo = Cfirst
   End With
   On Error GoTo 0

End Function

Private Function FilteredSheet(ToDo As Variant) As Variant
Dim ws As Worksheet

   FilteredSheet = 0
   For Each ws In Sheets
      If ws.Name = ToDo Then FilteredSheet = ws.Index
   Next ws
   
End Function
Private Function FilterProper(Sh As Worksheet, fItem As Long) As Variant
   With Sh
      If .AutoFilterMode Then
         If .AutoFilter.Range.Address = .UsedRange.Address Then
            With .AutoFilter
               If .Filters(fItem).On Then
                  With .Filters(fItem)
                     If .Operator = 0 Then FilterProper = Mid(.Criteria1, 2)
                  End With
               End If
            End With
         End If
      End If
   End With
End Function