Ich versuche mir ein Makro zusammen zu Basteln, das mir ein anderes Tabellenblatt in einer anderen Mappe auf Intelligente Tabellen überprüft diese dann filtert und kopiert. Falls es denn gesuchten Bereich nicht findet. Dann wird der Benutzte Bereich gefiltert und kopiert. Im Moment funktioniert es, so halb.
Es kopiert mir die Überschrift nicht mit. Außerdem kommt eine Meldung das eine große Menge Informationen in der zwischen Ablage sind und ob ich die behalten will. Ich weis leider nicht wie ich es weiter verbessern kann. Es würde jetzt so aussehen:
Private Sub Tab_Aktualisieren_Test()
Dim wksQuelle As Worksheet 'Arbeitsmappe (Datenquelle)
Dim wksZiel As Worksheet 'Arbeitsmappe (Ziel)
Dim lngLetzteZeile As Integer 'Letzte Zeile
Dim Pfad As String 'Pfad (Datenquelle)
Dim strFilter As String 'Filter Kriterium (Datenquelle)
Dim strKriterium As String 'Filter Nr. (Datenquelle)
Dim tblName As String 'Vergebener Name für Inteligente Tabelle/Liste
Pfad = "C:\Users\User\Desktop\Testdatei_Quelle.xlsx"
strFilter = "1"
strKriterium = ActiveSheet.Range("D1").Value
tblName = "Daten" 'Name des Bereiches
Set wksZiel = Workbooks("Testdatei.xlsm").Worksheets("Tabelle1")
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
With wksZiel
lngLetzteZeile = .UsedRange.Row + .UsedRange.Rows.Count 'Letzte benutzte Zeile ermitteln
If lngLetzteZeile > 3 Then 'Prüfen ob letzte benutzte _
Zeile kleiner 4
.Cells.FormatConditions.Delete
.Range(.Rows(3), .Rows(lngLetzteZeile)).EntireRow.Delete 'Alle Zeilen ab der 4. _
Zeile bis zur letzten benutzten Zeile löschen
End If
Workbooks.Open Filename:=Pfad, ReadOnly:=True
Set wksQuelle = Workbooks("Testdatei_Quelle.xlsx").Worksheets("Tabelle1")
With wksQuelle
'Prüfen ob benannte Tabelle existiert und Kopieren
If PrüfeListObjects(wksQuelle.Parent, tblName, wksQuelle.Name) = True Then
.ListObjects(tblName).Range.AutoFilter Field:=strFilter, Criteria1:= _
strKriterium
.Range(tblName).SpecialCells(xlCellTypeVisible).Copy
wksZiel.Range("A4").PasteSpecial xlPasteAll
Else
'Wenn benannte Tabelle nicht existiert dann Bereich anhand des benutzten bereiches _
Kopieren
.AutoFilter.ShowAllData
.UsedRange.AutoFilter Field:=strFilter, Criteria1:=strKriterium
.UsedRange.SpecialCells(xlCellTypeVisible).Copy wksZiel.Range("A1")
End If
ActiveWindow.Close SaveChanges:=False
End With
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Aktualisiert", vbInformation
End Sub
Ist es eigentlich möglich während des Kopierens die Spalten neu anzuordnen anhand der Überschrift? Es wäre echt großartig, wenn mir jemand etwas helfen könnte.
Testdatei - https://www.herber.de/bbs/user/130605.xlsm
Testdatei_Quelle (zum Abrufen der ausgangs Daten) - https://www.herber.de/bbs/user/130604.xlsx
Grüße Christian