Spalten selktiv nach Liste löschen (VBA)

Ich habe eine Frage an die Könner.
Wie bekomme ich es hin, nur Spalten einer Tabelle übrig zu lassen, deren Name in eine Hilfstabelle (gleiche Datei) aufgelistet sind?
Hintergrund ist, ich bekomme im Monat zwei mal Quelltabellen in denen ich nur ca.10 Spalten benötige. Alle anderen sollen gelöscht werden.
Leider und das ist das Problem verändert sich die Spaltenanzahl und die Lage (an welcher Stelle) die Spalten liegen. Das kann ich jedoch NICHT beeinflussen.
Heißt, so wie ich die Spalten in der Hilfstabelle aufliste soll das Ergebnis aussehen.
Bisher habe ich das völlig statisch gemacht. Allerdings hat sich die Änderung in der Tabelle massiv verschärft.
Könnte man Teile des hier gefundenen Codes vielleicht nutzen? In der Anwendung wird bedingt formatiert, aber vielleicht könnte man nicht formatieren, sonder herauslöschen. Allerdings gibt es hier keine Referenztabelle in der das Muster steht.
https://www.herber.de/forum/archiv/1912to1916/1914001_Bedingtform_ListObjects_Spaltenname.html

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Für ein Spaltenzahl i der vom letzte Überschriftspaltenummer bis erste Spalte (i absteigend) Wenn Zelle (Zeile der Überschrift, Spalte i) nicht in der Liste der Spalte zu behalten dann gesamte Spalte i löschen Ende Wenn Nächster i

Sub reinschreiben() Dim i As Long Const cKopfzeile = 1 For i = Cells(cKopfzeile, Columns.Count).End(xlToLeft).Column To 1 Step -1 If Worksheets("Spaltenliste").Range("A1:A10").Find(Cells(cKopfzeile, i)) Is Nothing Then Columns(i).Delete End If Next Z End Sub

Sub reinschreiben() Dim i As Long Const cKopfzeile = 1 For i = Cells(cKopfzeile, Columns.Count).End(xlToLeft).Column To 1 Step -1 If Worksheets("Spaltenliste").Range("A1:A10").Find(Cells(cKopfzeile, i), LookAt:=xlWhole) Is Nothing Then Columns(i).Delete End If Next Z End Sub

Sub reinschreiben() Dim i As Long Const cKopfzeile = 1 With Worksheets("Import_Tabelle") For i = .Cells(cKopfzeile, Columns.Count).End(xlToLeft).Column To 1 Step -1 If Worksheets("Spaltenliste").Range("A1:A10").Find(.Cells(cKopfzeile, i), LookAt:=xlWhole) Is Nothing Then .Columns(i).Delete End If Next Z End With End Sub

Sub Spalten_entfernen() Dim i As Long Dim Elt Const cKopfzeile = 1 With Worksheets("Import_Tabelle") For i = .Cells(cKopfzeile, Columns.Count).End(xlToLeft).Column To 1 Step -1 For Each Elt In Array("Überschrift 1", "Überschrift 2", "Überschrift 3") If LCase(.Cells(cKopfzeile, i)) = LCase(Elt) Then .Columns(i).Delete Exit For 'exit For Elt, also nächste i. End If Next Elt Next Z End With End Sub

Hallo Yal, erst mal vielen Dank das Du dich noch mal zu meinem Problem geäußert hast.
Die Variante die Du mir vorher gezeigt hast:

Sub reinschreiben()
       Dim i As Long
       Const cKopfzeile = 1
       
           With Worksheets("Import_Tabelle")
               For i = .Cells(cKopfzeile, Columns.Count).End(xlToLeft).Column To 1 Step -1
                   If Worksheets("Spaltenliste").Range("A1:A10").Find(.Cells(cKopfzeile, i), LookAt:=xlWhole) Is Nothing Then
                       .Columns(i).Delete
                   End If
               Next Z
           End With
       End Sub

Ist aus meiner Sicht die weit bessere Lösung. Denn sobald sich was an den Spalten ändert muss nur in der Spaltenliste etwas geändert werden, nicht im Code.
Derzeit habe ich folgendes am laufen:
Damit öffne ich die zu bearbeitende Import-Datei und springe dann in Deinen Code um die Spalten anzupassen. Das funkt. sehr gut.
Allerdings benötigt er die Spaltenliste in der Import-Datei.

Sub Loeschen_XLSX_das_Ausfuehren()		'rufe via Taster das Makro auf
    On Error GoTo ErrorHandler
    Abfrage = MsgBox("Sollen die Spalten angepasst werden?", vbYesNo + vbQuestion, "Sicherheitsabfrage")
        If Abfrage = vbYes Then
For Each Datei In Array("Import_Datei.xlsx")
    Workbooks.Open "D:\Test_Spaltenloeschung\" & Datei
    
    'hier muss aus meiner Sicht die Kopierfunktion der "Spaltenliste" Makro_Datei zur Import_Datei rein
    
    Call Spaltenloeschung_XLSX		'hier springt er in die Spaltenlöschung
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    
        MsgBox "Die Spalten wurden angepasst", , MyCaption
        GoTo Ende
Next
End If
ErrorHandler:
                MsgBox "Die Spalten wurden nicht angepasst", , MyCaption
Ende:
End Sub

Oder wir bekommen es hin, das er das kopieren nicht benötigt, und die Spaltenliste direkt aus der Makro_Datei in der Import_Datei nutzt.
Das wäre aus meiner Sicht die beste Lösung.
Ich habe auch schon mal hiermit versucht das Blatt "Spaltenliste" aus der Makro_Datei in die Importdatei zu bekommen, will aber irg. wie nicht klappen.
Sheets("Tabelle1").Copy Before:=Workbooks("Beispiel.xlsm").Sheets(1) 'Mit diesem Code wird ein Arbeitsblatt als erstes Arbeitsblatt in eine anderen Arbeitsmappe kopiert
Oder,
Sheets("Tabelle1").Copy After:=Workbooks("Beispiel.xlsm").Sheets(Workbooks("Beispiel.xlsm").Sheets.Count) 'So wird das Arbeitsblatt an das Ende der anderen Arbeitsmappe kopiert

Sub Loeschen_XLSX_das_Ausfuehren() 'rufe via Taster das Makro auf Dim WB As Workbook Dim i As Long Const cKopfzeile = 1 On Error GoTo Catch If MsgBox("Sollen die Spalten angepasst werden?", vbYesNo + vbQuestion, "Sicherheitsabfrage") = vbYes Then Try: Set WB = Workbooks.Open("D:\Test_Spaltenloeschung\Import_Datei.xlsx") 'Datei öffnen With WB.Worksheets(1) 'Spalten entfernen For i = .Cells(cKopfzeile, Columns.Count).End(xlToLeft).Column To 1 Step -1 If ThisWorkbook.Worksheets("Spaltenliste").Range("A1:A50").Find(.Cells(cKopfzeile, i), LookAt:=xlWhole) Is Nothing Then .Columns(i).Delete End If Next Z End With WB.Save WB.Close MsgBox "Die Spalten wurden angepasst", , MyCaption End If GoTo Finally Catch: MsgBox "Die Spalten wurden nicht angepasst", , MyCaption Finally: 'hier kommt, was auf alle Fälle (auch nach Fehler) gemachte werden muss Application.ScreenUpdating = True Application.EnableEvents = True End Sub

Sub Loeschen_XLSX_das_Ausfuehren() 'rufe via Taster das Makro auf Dim i As Long If MsgBox("Sollen die Spalten angepasst werden?", vbYesNo + vbQuestion, "Sicherheitsabfrage") = vbYes Then With Workbooks.Open("D:\Test_Spaltenloeschung\Import_Datei.xlsx").Worksheets(1) For i = .Cells(1, Columns.Count).End(xlToLeft).Column To 1 Step -1 If ThisWorkbook.Worksheets("Spaltenliste").Range("A1:A50").Find(.Cells(1, i), LookAt:=xlWhole) Is Nothing Then .Columns(i).Delete Next z .Close SaveChanges:=True End With End If End Sub

Beliebteste Forumthreads (12 Monate)

Spalten selktiv nach Liste löschen (VBA)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

315 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Spalten selktiv nach Liste löschen (VBA)

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

315 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread