ElseIf Abfrage Funktioniert nicht

'Counter festlegen Dim LC1 As Long LC1 = 1 'Collection zum sammeln der zu löschenden Element anlegen Dim RowsToDelete As Range 'Letzte Zeile ermitteln Dim LastRow As Long LastRow = getLastRow("DXFOutline") 'Spalten durchlaufen For LC1 = 1 To LastRow 'Überprüfen ob Zahlen in beiden Zellen sind If IsNumeric(Cells(LC1, 5).value) And IsNumeric(Cells(LC1, 8).value) Then 'Zeilen löschen, wenn Radius des Kreises = 0.4 If Abs(Cells(LC1, 5).value * 1000000 - Cells(LC1, 8).value * 1000000) = 0.4 * 1000000 Then If RowsToDelete Is Nothing Then Set RowsToDelete = Rows(LC1).Resize(2) ' Aktuelle Zeile und die nächste Zeile Else Set RowsToDelete = Union(RowsToDelete, Rows(LC1).Resize(2)) End If 'Zeilen löschen, wenn Radius des Kreises = -0.4 ElseIf Abs(Cells(LC1, 8).value * 1000000 - Cells(LC1, 5).value * 1000000) = 0.4 * 1000000 Then If RowsToDelete Is Nothing Then Set RowsToDelete = Rows(LC1).Resize(2) ' Aktuelle Zeile und die nächste Zeile Else Set RowsToDelete = Union(RowsToDelete, Rows(LC1).Resize(2)) End If End If End If Next LC1 If Not RowsToDelete Is Nothing Then RowsToDelete.Delete End If 'Counter festlegen Dim LC1 As Long LC1 = 1 'Collection zum sammeln der zu löschenden Element anlegen Dim RowsToDelete As Range 'Letzte Zeile ermitteln Dim LastRow As Long LastRow = getLastRow("DXFOutline") 'Spalten durchlaufen For LC1 = 1 To LastRow 'Überprüfen ob Zahlen in beiden Zellen sind If IsNumeric(Cells(LC1, 5).value) And IsNumeric(Cells(LC1, 8).value) Then 'Zeilen löschen, wenn Radius des Kreises = 0.4 If Abs(Cells(LC1, 5).value * 1000000 - Cells(LC1, 8).value * 1000000) = 0.4 * 1000000 Then If RowsToDelete Is Nothing Then Set RowsToDelete = Rows(LC1).Resize(2) ' Aktuelle Zeile und die nächste Zeile Else Set RowsToDelete = Union(RowsToDelete, Rows(LC1).Resize(2)) End If 'Zeilen löschen, wenn Radius des Kreises = -0.4 ElseIf Abs(Cells(LC1, 8).value * 1000000 - Cells(LC1, 5).value * 1000000) = 0.4 * 1000000 Then If RowsToDelete Is Nothing Then Set RowsToDelete = Rows(LC1).Resize(2) ' Aktuelle Zeile und die nächste Zeile Else Set RowsToDelete = Union(RowsToDelete, Rows(LC1).Resize(2)) End If End If End If Next LC1 If Not RowsToDelete Is Nothing Then RowsToDelete.Delete End If

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Nein die Dezimalzahlen in der Tabelle sind mit "," getrennt. Im vba Code muss ich jedoch "." verwenden.
Da das ersetzten von "," mit "." falsche Ergebnisse liefert, bin ich gezwungen es auf diese Art und Weise zu machen.

anbei das ganze Makro:
keine Ahnung warum des Code schon wieder 2 mal hintereinander angezeigt wird



Sub seperate_Outline()

'



    Application.ScreenUpdating = False

    Application.EnableEvents = False



    'alte Outline lï¿½schen

    Sheets("DXFOutline").Cells.Clear

    

    'Kopieren des DXFImports

    Sheets("DXFDatei").Select

    Cells.Select

    Selection.Copy

    Sheets("DXFOutline").Select

    Range("A1").Select

    ActiveSheet.Paste

    

    'Counter festlegen

    Dim LC1 As Long

    LC1 = 1

    

    'Collection zum sammeln der zu lï¿½schenden Element anlegen

    Dim RowsToDelete As Range

    

    'Letzte Zeile ermitteln

    Dim LastRow As Long

    LastRow = getLastRow("DXFOutline")

    

    'Spalten durchlaufen

    For LC1 = 1 To LastRow

    

        'ï¿½berprï¿½fen ob Zahlen in beiden Zellen sind

        If IsNumeric(Cells(LC1, 5).value) And IsNumeric(Cells(LC1, 8).value) Then

        

            'Zeilen lï¿½schen, wenn Radius des Kreises = 0.4

            If Abs(Cells(LC1, 8).value * 1000000 - Cells(LC1, 5).value * 1000000) = 0.4 * 1000000 Then

                If RowsToDelete Is Nothing Then

                    Set RowsToDelete = Rows(LC1).Resize(2) ' Aktuelle Zeile und die nï¿½chste Zeile

                Else

                    Set RowsToDelete = Union(RowsToDelete, Rows(LC1).Resize(2))

                End If

            End If

            

        End If

            

    Next LC1

    

    If Not RowsToDelete Is Nothing Then

        RowsToDelete.Delete

    End If

    

    ThisWorkbook.Worksheets("User Interface").Activate

        



    Application.ScreenUpdating = True

    Application.EnableEvents = True

    

    MsgBox "Outline wurde erfolgreich getrennt.", vbInformation, "seperate_Outline"

    



End Sub



Private Function getLastRow(Blatt As String)

    

    ThisWorkbook.Worksheets(Blatt).Activate



    Dim TotalRow As Long

    

    getLastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row

    

    ThisWorkbook.Worksheets("DXFOutline").Activate



End Function


Sub seperate_Outline()
'

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    'alte Outline lï¿½schen
    Sheets("DXFOutline").Cells.Clear
    
    'Kopieren des DXFImports
    Sheets("DXFDatei").Select
    Cells.Select
    Selection.Copy
    Sheets("DXFOutline").Select
    Range("A1").Select
    ActiveSheet.Paste
    
    'Counter festlegen
    Dim LC1 As Long
    LC1 = 1
    
    'Collection zum sammeln der zu lï¿½schenden Element anlegen
    Dim RowsToDelete As Range
    
    'Letzte Zeile ermitteln
    Dim LastRow As Long
    LastRow = getLastRow("DXFOutline")
    
    'Spalten durchlaufen
    For LC1 = 1 To LastRow
    
        'ï¿½berprï¿½fen ob Zahlen in beiden Zellen sind
        If IsNumeric(Cells(LC1, 5).value) And IsNumeric(Cells(LC1, 8).value) Then
        
            'Zeilen lï¿½schen, wenn Radius des Kreises = 0.4
            If Abs(Cells(LC1, 8).value * 1000000 - Cells(LC1, 5).value * 1000000) = 0.4 * 1000000 Then
                If RowsToDelete Is Nothing Then
                    Set RowsToDelete = Rows(LC1).Resize(2) ' Aktuelle Zeile und die nï¿½chste Zeile
                Else
                    Set RowsToDelete = Union(RowsToDelete, Rows(LC1).Resize(2))
                End If
            End If
            
        End If
            
    Next LC1
    
    If Not RowsToDelete Is Nothing Then
        RowsToDelete.Delete
    End If
    
    ThisWorkbook.Worksheets("User Interface").Activate
        

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    MsgBox "Outline wurde erfolgreich getrennt.", vbInformation, "seperate_Outline"
    

End Sub

Private Function getLastRow(Blatt As String)
    
    ThisWorkbook.Worksheets(Blatt).Activate

    Dim TotalRow As Long
    
    getLastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
    
    ThisWorkbook.Worksheets("DXFOutline").Activate

End Function

Sub seperate_Outline2() Dim z With Worksheets("DXFDatei") For z = 1000 To 1 Step -1 If IsNumeric(.Cells(z, 5)) Then If Abs(.Cells(z, 5) - .Cells(z, 8)) = 0.4 Then .Rows(z).Delete .Rows(z + 1).Delete End If End If Next z End With End Sub

Sub seperate_Outline2() Dim z With Worksheets("DXFOutline") For z = 1000 To 1 Step -1 If IsNumeric(.Cells(z, 5)) Then If Abs(.Cells(z, 5) - .Cells(z, 8)) = 0.4 Then .Rows(z).Delete .Rows(z + 1).Delete End If End If Next z End With End Sub

Sub seperate_Outline2() Dim z With Worksheets("DXFOutline") For z = 1000 To 1 Step -1 If IsNumeric(.Cells(z, 5)) Then If Abs(.Cells(z, 5) - .Cells(z, 8)) = 0.4 Then .Rows(z + 1).Delete .Rows(z).Delete End If End If Next z End With End Sub

Beliebteste Forumthreads (12 Monate)

ElseIf Abfrage Funktioniert nicht

26
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

ElseIf Abfrage Funktioniert nicht

26 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

26
Beiträge zum Forumthread

Beiträge zu diesem Forumthread