Gruppe
Allgemein
Problem
Alle Zeilen und Spalten unterhalb bzw. rechts von der letzten Zelle mit Wert sollen gelöscht werden.
StandardModule: Modul1
Sub DeleteRange()
Dim wks As Worksheet
Dim rng As Range
Dim iCounter As Integer
For iCounter = ActiveSheet.Index + 1 To Worksheets.Count
Set wks = Worksheets(iCounter)
Set rng = RealLastCell(wks)
wks.Rows(rng.Row + 1 & ":" & Rows.Count).Delete
wks.Range(wks.Cells(1, rng.Column + 1), _
wks.Cells(1, 256)).EntireColumn.Delete
Next iCounter
End Sub
Function RealLastCell(TheSheet As Worksheet) As Range
Dim ExcelLastCell As Range
Dim Row%, Col%, LastRowWithData%, LastColWithData%
Application.ScreenUpdating = False
Set ExcelLastCell = TheSheet.Cells.SpecialCells(xlLastCell)
LastRowWithData = ExcelLastCell.Row
Row = ExcelLastCell.Row
Do While Application.CountA(TheSheet.Rows(Row)) = 0 And Row <> 1
Row = Row - 1
Loop
LastRowWithData = Row
LastColWithData = ExcelLastCell.Column
Col = ExcelLastCell.Column
Do While Application.CountA(TheSheet.Columns(Col)) = 0 And Col <> 1
Col = Col - 1
Loop
LastColWithData = Col
Set RealLastCell = TheSheet.Cells(Row, Col)
End Function