Prozente kleiner 2 löschen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Steffi,
das folgende Makro sollte Deinen Wunsch erfüllen :
Im angegebenen Bereich werden alle Daten (also die Nr. und der %-Satz) gelöscht, die kleiner als 2% sind.
Die nachfolgenden Daten der Zeile werden nach links verschoben (allerdings nicht nach oben !)

Sub Raetsel_Nicht_nur_lesen_sondern_auch_lOesen()
    'Löscht alle Daten <2 % im angegebenen Bereich (jeweils 2 Zellen)
    Dim Bereich, Zeile, Spalte
    Set Bereich = [G42:EQ450]
    For Each ber In Bereich.SpecialCells(xlCellTypeConstants, 23).Areas
        For Zeile = ber.Row To ber.Rows.Count + ber.Row - 1
            For Spalte = ber.Column + 1 To ber.Columns.Count + ber.Column Step 2
                If Cells(Zeile, Spalte).Value < 0.02 And Cells(Zeile, Spalte).Value <> "" Then
                    Cells(Zeile, Spalte).Offset(0, -1).Resize(, 2).Delete shift:=xlToLeft
                    Spalte = Spalte - 2
                End If
            Next
        Next
    Next
End Sub
Teste das Makro bitte zunächst an einer Kopie Deiner Tabelle !!
Gruß, NoNet

Sub umwandeln_loeschen() Dim raZelle As Range Dim raZellen As Range For Each raZelle In ActiveSheet.UsedRange If Right(raZelle, 1) = "%" Then Cells(raZelle.Row, raZelle.Column) = CDbl(Left(raZelle, Len(raZelle) - 1)) / 100 Cells(raZelle.Row, raZelle.Column).NumberFormat = "0.00%" End If Next raZelle For Each raZelle In ActiveSheet.UsedRange If raZelle 0 Then If raZellen Is Nothing Then Set raZellen = Union(raZelle, raZelle.Offset(0, -1)) Else Set raZellen = Union(raZellen, raZelle, raZelle.Offset(0, -1)) End If End If Next raZelle If Not raZellen Is Nothing Then raZellen.Delete shift:=xlShiftToLeft Set raZellen = Nothing End Sub

Sub loeschen() Dim raZelle As Range Dim raZellen As Range For Each raZelle In ActiveSheet.UsedRange If raZelle 0 Then If raZellen Is Nothing Then Set raZellen = Union(raZelle, raZelle.Offset(0, -1)) Else Set raZellen = Union(raZellen, raZelle, raZelle.Offset(0, -1)) End If End If Next raZelle If Not raZellen Is Nothing Then raZellen.Delete shift:=xlShiftToLeft ' hier werden alle _ Zellen auf einmal gelöscht und verschoben Set raZellen = Nothing End Sub

Hallo Steffi
scheint ja ein schwieriger Fall zu sein.
Leider kann ich deine Origingal-Datei nicht mehr hochladen, aber ich hoffe, das Beispiel von NoNet entspricht noch dieser.
ich hab mal was gebastelt, mit der Datei funktionierts es auch recht zügig, hoffentlich dann auch im Original.
Anzumerken ist, daß die Originaldaten nicht verändert werden, sondern die Werte in Tabelle2 übertragen und dort bearbeitet werden. Dadurch kann ich mit Formeln arbeiten und spare mir die Schleifen, dh. das Makro ist kurz und sollte recht flott sein.
Hier der Code:


Sub Test()
With Sheets("tabelle2").Range(Sheets("Tabelle1").UsedRange.Address)
.FormulaR1C1 = "=IF(Tabelle1!RC="""","""",IF(ISERROR(VALUE(Tabelle1!RC)),Tabelle1!RC,IF( _
VALUE(Tabelle1!RC)

und hier die Datei:
https://www.herber.de/bbs/user/46622.xls
Gruß, Daniel

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

39 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Prozente kleiner 2 löschen

19 Beiträge zum Forumthread Beiträge zu diesem Forumthread

39 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread