Forums Neueste Beiträge
 

Kumulatives Löschen

26/03/2010 - 18:37 von Hans Berger | Report spam
Aus einer Vielzahl von Excel-Dateien will ich jeweils die ersten und letzten
20 Zeilen löschen. Gibt es eine Möglichkeit, dies kumulativ zu tun, oder muss
ich wirklich jede Datei einzeln zum Löschen aufmachen?

Gruß
Hans
 

Lesen sie die antworten

#1 Andreas Killer
27/03/2010 - 12:21 | Warnen spam
Hans Berger schrieb:

Aus einer Vielzahl von Excel-Dateien will ich jeweils die ersten und
letzten 20 Zeilen löschen. Gibt es eine Möglichkeit, dies kumulativ zu
tun, oder muss ich wirklich jede Datei einzeln zum Löschen aufmachen?


Nein, das kann man mit einem Makro erledigen.

Der Code muss in ein normales Modul, wie's geht steht hier:
http://www.online-excel.de/excel/si....php?fD#s2

Speichere die Mappe in dem Ordner der zu manipulierenden Dateien und
starte es. Falls ein Fehler auftritt erscheint eine Meldung und der
Dateiname wird in der Tabelle abgespeichert.

Andreas.

Option Explicit
Option Compare Text

Sub Test()
Const Zeilen = 1
Dim fs As Object, F As Object, Data
Dim WB As Workbook, R As Range, Y As Long, I As Long
Set fs = CreateObject("Scripting.FileSystemObject")

'Dateinamen einlesen
I = fs.GetFolder(ThisWorkbook.Path).Files.Count
ReDim Data(1 To I)
I = 0
For Each F In fs.GetFolder(ThisWorkbook.Path).Files
I = I + 1
Data(I) = F.Name
Next

'Fehlerbehandlung etablieren
On Error GoTo Errorhandler

For I = 1 To UBound(Data)
'Ist es ein Excel-File?
If fs.GetExtensionName(Data(I)) = "XLS" Then
'Ist es nicht unseres?
If Not Data(I) = ThisWorkbook.Name Then
'Datei öffnen
Set WB = Workbooks.Open(Data(I))
'Letzte Zelle ermitteln
Set R = SheetLastCell(WB.Sheets(1))
'Genug Zeilen da?
If R.Row < 2 * Zeilen Then GoTo Errorhandler
'Zeilen am Ende löschen
Rows(R.Row & ":" & R.Row - (Zeilen - 1)).Delete
'Erste Zeile
Set R = Range("A1")
'Zeilen am Anfang löschen
Rows(R.Row & ":" & R.Row + (Zeilen - 1)).Delete
'Datei zu, speichern
WB.Close True
End If
End If
NextFile:
Next
Exit Sub

Errorhandler:
Y = Y + 1
ThisWorkbook.Sheets(1).Cells(Y, 1) = Data(I)
MsgBox "Fehler in Datei " & Data(I) & " aufgetreten, Datei " & _
"wird nicht gespeichert! Zum Fortfahren OK klicken."
'Datei zu, nicht speichern
WB.Close False
Err.Clear
GoTo NextFile
End Sub

Private Function SheetLastCell(Optional S As Worksheet) As Range
'Liefert die letzte verwendete Zelle der Tabelle
Dim R As Range, C As Range
If S Is Nothing Then Set S = ActiveSheet

'Dies allein geht auch, setzt aber die letzte Zelle (Strg- _
Ende) zurück:
'Set R = S.UsedRange.Cells.SpecialCells(xlCellTypeLastCell)

Set R = S.Cells.SpecialCells(xlCellTypeLastCell)
If IsEmpty(R) And Not R.Address = Cells(1, 1).Address Then
Set C = S.Cells.Find("*", After:=R, SearchOrder:= _
xlByColumns, SearchDirection:=xlPrevious)
If C Is Nothing Then
Set SheetLastCell = S.Cells(1, 1)
Else
Set R = S.Cells.Find("*", After:=R, SearchOrder:= _
xlByRows, SearchDirection:=xlPrevious)
Set SheetLastCell = S.Cells(R.Row, C.Column)
End If
Else
Set SheetLastCell = R
End If
End Function

Ähnliche fragen