ganze Spalten in Range mit Beding. löschen
24.06.2020 16:47:46
Andreas
ich brauche mal eure Hilfe. Im folgenden Code werden aus einem Reiter Daten in einen anderen Reiter (eine Vorlage) kopiert. Da die Vorlage mehr Spalten hat, um alle Möglichkeiten wieder zu geben, sollen die gelöscht werden, welche in Zeile 6 Grüße Andreas
Sub Test()
Dim CellRange As Range
Dim rngCell As Range
Set tp = Worksheets("Planung")
Set tv = Worksheets("Verteilung")
Set vl = Worksheets("Vorlage")
Set insert_after = tp
tv.UsedRange.Delete
Sheets("Vorlage").Visible = True
TName = "A13 EG"
vl.Copy After:=insert_after
ActiveSheet.Name = "A13 EG"
Set T_sheet = Worksheets(TName)
Set insert_after = T_sheet
' Filter zurücksetzen
ResetAutoFilter
' Alle Spalten einblenden
tp.Columns.EntireColumn.Hidden = False
' Bereich auswaehlen
EndRow = tp.Cells(tp.Rows.Count, 1).End(xlUp).Row
Set alltours = tp.Range(tp.Cells(1, 1), tp.Cells(EndRow, 40))
alltours.AutoFilter Field:=2, Criteria1:="*A13 EG*"
' Spalten verbergen
tp.Columns(1).EntireColumn.Hidden = True
tp.Columns(3).EntireColumn.Hidden = True
tp.Columns(4).EntireColumn.Hidden = True
tp.Columns(5).EntireColumn.Hidden = True
tp.Columns(42).EntireColumn.Hidden = True
tp.Columns(43).EntireColumn.Hidden = True
tp.Columns(44).EntireColumn.Hidden = True
tp.Columns(47).EntireColumn.Hidden = True
tp.Columns(48).EntireColumn.Hidden = True
tp.Rows(1).EntireRow.Hidden = True
On Error Resume Next
alltours.SpecialCells(xlCellTypeVisible).Copy
T_sheet.Cells(8, 2).PasteSpecial xlPasteValues
On Error GoTo 0
' Spalten und Zeilen auf dem Reitern verbergen, HIER BENÖTIGE ICH DIE HILFE
Set CellRange = Range("D3:AK3")
For Each rngCell In CellRange.Cells
rngCell.EntireColumn.Delete = rngCell.Value