vorhandenes Makro -> Autofilter leeren

Option Explicit
Const HomeDatei = "LeereArbeitsmappe.xls"    'Name Arbeitsmappe Makro-Excel-Datei
Const HomeDaten = "Import-Daten"          'Name Tabellenblatt Daten-Import
Const HomeListe = "Datei-Liste"           'Name Tabellenblatt Datei-Liste
Const HomeZeile = 3                       'Erste Zeile Einfügen
Const CopyZeile = 3                       'Erste Zeile Kopieren
Const ListDatei = "A1"                    'Zelle erster Dateiname
Const ErrMsg = "Abbruch! Datei existiert nicht: "
Sub SheetsImportS()              ' www.herber.de/forum/archiv/1112to1116/t1114531.htm
Dim WksHome As Worksheet, WksList As Worksheet, EndLine As Long, NextLine As Long
Dim WkbCopy As Workbook, WksCopy As Worksheet, Fso As Object, rngFile As Range
Dim lngAnzZ As Long, lngSpA As Long, ii As Long, aStrU(), varU, lngU As Long
Set WksHome = Workbooks(HomeDatei).Sheets(HomeDaten)
Set WksList = Workbooks(HomeDatei).Sheets(HomeListe)
EndLine = GetEndLine(WksHome)
If EndLine >= HomeZeile Then WksHome.Rows("3:" & EndLine).ClearContents
NextLine = HomeZeile
' Titel aus Zeile 1 des Zielblatts in Array aStrU sammeln
With WksHome
lngSpA = .Cells(1, .Columns.Count).End(xlToLeft).Column
If lngSpA > 1 Then
aStrU = Application.Transpose(Application.Transpose( _
.Cells(1, 1).Resize(, lngSpA)))
ElseIf .Cells(1, 1) = "" Then
MsgBox "Abbruch - Keine Spaltenüberschriften in Zeile 1 des Zielblatts"
Exit Sub
Else
ReDim aStrU(1 To 1)
aStrU(1) = .Cells(1, 1).Value2
End If
End With
'    Application.ScreenUpdating = False               ' NACH dem Test aktivieren
Set Fso = CreateObject("Scripting.FileSystemObject")
Application.EnableEvents = False
For Each rngFile In WksList.Range(ListDatei).CurrentRegion
If Fso.FileExists(rngFile) = False Then
Application.ScreenUpdating = True
MsgBox ErrMsg & rngFile, vbExclamation, "Fehler":  Exit Sub
End If
Set WkbCopy = Workbooks.Open(rngFile, False, True)       ' Quelle öffnen
Set WksCopy = WkbCopy.Sheets(1)
EndLine = GetEndLine(WksCopy)
If EndLine >= CopyZeile Then
lngAnzZ = EndLine - CopyZeile + 1      ' Anzahl zu kopierender Zeilen
For ii = 1 To lngSpA                ' Spaltenüberschriften in Quelle suchen
varU = Application.Match(aStrU(ii), WksCopy.Rows(1), 0)
If IsNumeric(varU) Then
lngU = varU                   ' wenn Treffer, Spalte kopieren
WksHome.Cells(NextLine, ii).Resize(lngAnzZ) = _
WksCopy.Cells(CopyZeile, lngU).Resize(lngAnzZ).Value2
End If
Next ii
NextLine = NextLine + lngAnzZ
End If
WkbCopy.Close SaveChanges:=False
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Function GetEndLine(ByRef Wks) As Long
GetEndLine = Wks.Cells(Wks.Rows.Count, 1).End(xlUp).Row
End Function