Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1696to1700
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Intelligente Tabellen kopieren und umgestalten

Intelligente Tabellen kopieren und umgestalten
26.06.2019 20:12:32
Christian
Hallo an allerseits
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

    8
    Beiträge zum Forumthread
    Beiträge zu diesem Forumthread

    Betreff
    Datum
    Anwender
    Anzeige
    AW: Intelligente Tabellen kopieren und umgestalten
    26.06.2019 20:15:24
    Christian
    Das ist noch die Funktion die ich mir rausgesucht hab für die Prüfung ob die Tabelle/Liste vorhanden ist.
    Private Function PrüfeListObjects(wkb As Workbook, ByVal strName As String, ByVal strSheet As  _
    String) As Boolean
    Dim objList As Object
    ' Gehe durch alle Listobjekte auf dem Tabellenblatt
    For Each objList In wkb.Worksheets(strSheet).ListObjects
    ' Wenn der Name des Listobjektes übereinstimmt, dann...
    If objList.Name = strName Then
    ' Funktion gibt Wahr zurück
    PrüfeListObjects = True
    ' Arbeit erledigt, verlasse die Funktion
    Exit Function
    Else
    ' Sonst gibt die Funktion Falsch zurück
    PrüfeListObjects = False
    End If
    Next objList
    End Function
    
    Grüße Christian
    Anzeige
    AW: Intelligente Tabellen kopieren und umgestalten
    27.06.2019 13:53:53
    fcs
    Hallo Christian,
    Problem große Datenmenge:
    Du musst Zeile
    Application.CutCopyMode = False
    ausführen bevor die Quelldatei geschlossen wird.
    Problem Kopfzeile:
    Du musst den gleichen Zellbereich kopieren, auf den der Autofilter angewendet wird.
    Zusätzlich kann man den Code etwas einfacher/übersichtlicher gestalten, wenn man für die Quell-Arbeitsmappe(Datei) eine Objektvariable verwendet.
    Die angepassten/neuen Zeilen hab ich markiert. Für deine 2 Problem mit "!!!xxx!!!.
    Für die Optimierungen mit "###xxx###.
    LG
    Franz
    Private Sub Tab_Aktualisieren_Test()
    Dim wkbQuelle As Workbook               'Arbeitsmappe (Datenquelle) '###neu###
    Dim wksQuelle As Worksheet              'Tabellenblatt (Datenquelle)'###geändert###
    Dim wksZiel As Worksheet                'Tabellenblatt (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")
    Set wksZiel = ThisWorkbook.Worksheets("Tabelle1") '###geändert###
    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
    Set wkbQuelle = Application.Workbooks.Open(Filename:=Pfad, ReadOnly:=True)  '###geändert###
    Set wksQuelle = wkbQuelle.Worksheets("Tabelle1")                            '###geändert###
    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
    .ListObjects(tblName).Range.SpecialCells(xlCellTypeVisible).Copy      '!!!geä _
    ndert!!!
    wksZiel.Range("A4").PasteSpecial xlPasteAll
    Else
    'Wenn benannte Tabelle nicht existiert dann Bereich anhand des benutzten bereiches  _
    Kopieren
    If .AutoFilterMode = True Then If .FilterMode = True Then .AutoFilter. _
    ShowAllData
    .UsedRange.AutoFilter Field:=strFilter, Criteria1:=strKriterium
    .UsedRange.SpecialCells(xlCellTypeVisible).Copy wksZiel.Range("A1")
    End If
    Application.CutCopyMode = False                                       '!!!neu!!! _
    wkbQuelle.Close SaveChanges:=False                                    '###geä _
    ndert###
    End With
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "Aktualisiert", vbInformation
    End Sub
    

    Anzeige
    AW: Intelligente Tabellen kopieren und umgestalten
    27.06.2019 18:01:10
    Christian
    Hallo :)
    Danke für deine Hilfe. Deine Art zu Antworten ist wirklich sehr verständlich und strukturiert, echt super. Es Funktioniert bestens und es ist jetzt auch wesentlich übersichtlicher 😊 Wenn Du oder jemand im Forum vielleicht Zeit hätte mir bei dem Makro noch etwas weiter zu helfen. Ich bin mir nicht so sicher, ob ich es allein fertigbekomme.
    Ich will in einer Variante mit dem Makro zwei bestimmte intelligente Tabellen. Aus der Quellmappe in die Zielmappe bekommen. Und in einer zweiten Variante nur bestimmte Spalten aus der Intelligenten Tabelle. Als Neue Intelligente Tabelle,in die Zielmappe. In einer bestimmten Reihenfolge übernehmen.
    Daher habe ich jede Menge Fragen:
  • Wie Prüfe ich ob die Quellmappe nicht schon geöffnet ist.Ich will bei dem Kopiervorgang nichts in der Mappe ändern aber wenn sie schon offen ist und dann geschlossen wird dann geht der Speicherstand verloren. Daran hab ich am anfang nicht gedacht. Das würde ich gerne verhindern.

  • Ist es beim Kopieren von den Intelligente Tabellen möglich sie so zu Kopieren das es in der neuen Mappe auch noch eine Intelligente Tabelle ist ev. Mit demselben oder einen anderen Namen?

  • Wüsstest du eine Möglichkeit wie ich das Makro am besten auf zwei Intelligente Tabellen ausweiten kann. Also das eine zweite Intelligente Tabellen die in derselben Quellmappe auf dem selben Tabellenblatt ist ,drei Zeilen unter die erste eingesetzt wird?

  • Und das Schwerste:Wüsstest du vielleicht eine Möglichkeit wie ich am effektivsten, nur bestimmte Spalten in einer vorgegebenen Reihenfolge aus der Quellmappe. Anhand der Überschriften in die Zielmappe bekomme. Also das ich im Code ein Array mit den Überschriften in entsprechender reichenfolge angebe bsp. auf die Überschriften in der Testdatei bezogen: Array(Daten9, Daten15, Daten20, Daten5, Daten18, Daten1)

  • Bin für jeden Input/Hilfe Dankbar.
    Grüße Christian
    Anzeige
    AW: Intelligente Tabellen kopieren und umgestalten
    28.06.2019 11:51:02
    fcs
    Hallo Christian,
    deine Wunschliste kann man umsetzen.
    Makros siehe Textdatei.
    https://www.herber.de/bbs/user/130631.txt
    Makro Tab_Aktualisieren_Test_2_Tabs
    - prüft ob Quelle geöffnet
    - arbeitet in einer Schleife 2 "intelligente" Tabellen ab
    - wandelt die Zellbereiche mit den kopierten Daten wieder in "intelligente" Tabelle um
    Makro Tab_Aktualisieren_Test_Spalten
    kopiert zusätzlich nur die vorgegebenen Spaltentitel
    LG
    Franz
    AW: Intelligente Tabellen kopieren und umgestalten
    01.07.2019 12:48:42
    Markus
    Hallo Vielen dank für die zwei echt; super das du dir die Zeit genommen hast 
    Sie Funktionieren im Prinzip auch, es ist nur eine Codzeile dabei die mir einen Fehler verursacht und zwar erst beim Nochmaligen ausführen und zwar die hier.
    
    .ListObjects(.ListObjects.Count).Name = tblName(iTab)
    
    Es ist die Zuweisung des Namens für die Intelligenten Tabellen und sollte eigentlich Funktionieren. Hast du Vielleicht eine Idee warum es dennoch nicht geht? Und wäre es möglich das in der Quellmappe in dem Fall das die Quellmappe schon offen war der gesetzte Filter wider gelöst wird.
    Danke für die Hilfe
    Grüße Christian
    Anzeige
    AW: Intelligente Tabellen kopieren und umgestalten
    01.07.2019 13:54:00
    fcs
    Hallo Christian,
    ich hab keine Ahnung, warum die Umbenennung der Tabellen in dem Zielblatt nicht immer funktioniert.
    Ich hab jetzt einfach eine Fehlerbehandlung eingefügt, so dass ggf. in der nächsten Zeile weitergemacht wird.
    Das Zurücksetzen des Filters in der geöffneten Quelldatei ist auch drin.
    Textdatei mit angepassten Makros
    https://www.herber.de/bbs/user/130678.txt
    LG
    Franz
    AW: Intelligente Tabellen kopieren und umgestalten
    01.07.2019 20:45:52
    Christian
    Hallo Franz
    Vielen Dank für die ganze Hilfe. Auf meinem Laptop funktioniert es. Der Fehler scheint was mit dem Pc in der Arbeit zu tun zu haben. Es ist ein Thin client system und die sind sehr langsam. Vielleicht provoziert das den Fehler. Es scheint so zu sein das er irgendwie ein Problem hat das die Intelligenten Tabellen in der Quelle und der Zielmappe gleich Heisen. Sozusagen das er auf die falsche zugreift.
    Ich werd Versuchen dem Problem Herr zu werden und vielleicht noch einen Weg suchen das Makro schneller zu machen, wenn das überhaupt geht.
    Du hast mir in jedem Fall sehr geholfen, vielen Dank dafür
    Grüße Christian
    Anzeige
    AW: Intelligente Tabellen kopieren und umgestalten
    01.07.2019 13:50:53
    Christian
    Der fehler lautet: "Anwendungs- oder Objektdefinierter Fehler"
    Grüße Christian

    300 Forumthreads zu ähnlichen Themen

    Anzeige
    Anzeige
    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige
    Anzeige
    Anzeige