AW: Zellen zwischen 2 gleichen Zellen löschen
07.09.2007 20:03:03
Moritz
Hey Daniel,
super Makro! Funktioniert klasse, auch wenn ich kurz gedacht habe, dass mein Excel gerade crashed, weil es soooo lange zum rechnen gebraucht hat ;-). Sind halt knapp 25.000 Zeilen. Eine klitze kleines Problem habe ich aber noch, weil ich kann es irgendwie nicht in mein Ursprungsmakro einbauen, was vorher alles passieren soll. Ich habe mal ganz unten hingeschrieben wo ich es gerne hätte.
Sub auto_open()
Dim optCalcMode As Long
Dim nRowsCnt As Long
Dim nRow As Long
'ggf. Laufwerk und Ordner als Vorgabe setzen
ChDrive ActiveWorkbook.Path
ChDir ActiveWorkbook.Path
'Das Dialogfenster
dateiname = Application.GetOpenFilename _
(" Alle Dateien (*.*), *.*,Micrsoft Excel-Dateien (*.xls),*.xls,")
If dateiname False Then
ActiveWorkbook.Activate
On Error Resume Next
Workbooks.OpenText Filename:=dateiname, Origin:=xlWindows _
, StartRow:=8, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array( _
_
1, 1), Array(14, 1), Array(18, 1), Array(40, 1), Array(58, 1), _
Array(62, 1), Array(80, 1), Array(86, 1), Array(93, 1)), _
TrailingMinusNumbers:=True
'Sortieren der Daten
Columns("H:H").Select
Selection.Delete Shift:=xlToLeft
Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
Columns("D:D").Select
Selection.Delete Shift:=xlToLeft
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
ActiveCell.FormulaR1C1 = "Uo"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Stelle"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Dm"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Dat"
Else
End If
'Löschen von leeren und unnützen Zeilen
With Worksheets(1)
If Application.WorksheetFunction.CountA(.Cells) > 0 Then
optCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
nRowsCnt = .Cells.Find(What:="*", _
After:=.Range("A1"), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row - 1
For nRow = nRowsCnt + 1 To 1 Step -1
Application.StatusBar = "Bearbeite Zeile " & nRow
If Application.WorksheetFunction.CountA( _
.Rows(nRow).EntireRow) = 0 Then
.Rows(nRow).EntireRow.Delete
End If
If Range("A" & nRow).Value = "WP-KENNUNG" Then
.Rows(nRow).EntireRow.Delete
End If
If Range("A" & nRow).Value = "------------" Then
.Rows(nRow).EntireRow.Delete
End If
If Range("E" & nRow).Value = "DEP-ART" Then
.Rows(nRow).EntireRow.Delete
End If
If Range("B" & nRow).Value = "****" Then
.Rows(nRow).EntireRow.Delete
End If
If Range("C" & nRow).Value = "" Then
.Rows(nRow).EntireRow.Delete
End If
If Range("D" & nRow).Value = "" Then
.Rows(nRow).EntireRow.Delete
End If
If Range("E" & nRow).Value = "0" Then
.Rows(nRow).EntireRow.Delete
End If
Next nRow
HIER SOLL ES EINGEBAUT WERDEN
'Worksheet umformatieren
Cells.Select
Cells.EntireColumn.AutoFit
Application.Calculation = optCalcMode
Application.ScreenUpdating = True
Range("A1").Select
End If
End With
ENDE:
Application.StatusBar = ""
End Sub