Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1248to1252
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Löschen Code ergänzung

Löschen Code ergänzung
Karel
Hallo beisammen,
Habe untenstehende Code im Forum gefunden:
https://www.herber.de/forum/archiv/1112to1116/t1115753.htm
Es ist genau was ich brauche, aber ich mochte gerne eine ergänzung dazu.
Wenn kein wert im Spalte C ist dann betreffend Zeile komplett Löschen.
Option Explicit
Sub Worksheet_Activate()
Dim N As Long
Dim Dx As Range
Dim Mx As Range
Dim Col As Integer
Dim Nx As Range
Dim Zeile As Long
Application.ScreenUpdating = False
With Worksheets("Atribute")
Set Dx = Worksheets("T1").Range("B2")
N = .Cells(Rows.Count, 1).End(xlUp).Row
For Each Nx In .Range("A2:A" & CStr(N))
Application.StatusBar = Nx.Value
For Each Mx In .Range("B1:N1")
Dx.Offset(Col, -1).Value = Nx.Value
Dx.Offset(Col, 0).Value = Mx.Value
Dx.Offset(Col, 1).Value = Mx.Offset(Nx.Row - 1, 0).Value
Col = Col + 1
Next
Next
Application.ScreenUpdating = True
End With
End Sub

Danke und Gruß Karel

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Löschen Code ergänzung
16.02.2012 21:20:28
Josef

Hallo Karel,
Sub Worksheet_Activate()
  Dim N As Long
  Dim Dx As Range, rngDel As Range
  Dim Mx As Range
  Dim Col As Integer
  Dim Nx As Range
  Dim Zeile As Long
  Application.ScreenUpdating = False
  With Worksheets("Atribute")
    Set Dx = Worksheets("T1").Range("B2")
    N = .Cells(Rows.Count, 1).End(xlUp).Row
    For Each Nx In .Range("A2:A" & CStr(N))
      If .Cells(Nx.Row, 3) = "" Then
        If rngDel Is Nothing Then
          Set rngDel = .Rows(Nx.Row)
        Else
          Set rngDel = Union(rngDel, .Rows(Nx.Row))
        End If
      Else
        Application.StatusBar = Nx.Value
        For Each Mx In .Range("B1:N1")
          Dx.Offset(Col, -1).Value = Nx.Value
          Dx.Offset(Col, 0).Value = Mx.Value
          Dx.Offset(Col, 1).Value = Mx.Offset(Nx.Row - 1, 0).Value
          Col = Col + 1
        Next
      End If
    Next
    If Not rngDel Is Nothing Then rngDel.Delete
    Application.ScreenUpdating = True
  End With
End Sub



« Gruß Sepp »

Anzeige
AW: Löschen Code ergänzung
16.02.2012 21:43:34
Karel
Hallo Sep
habe es grade probiert aber unter Excel 2003 aber Zeile werden nicht gelöscht wenn Zellwert im Spalte C leer ist.
Habe meine Datei angehängt zum verständnis.
https://www.herber.de/bbs/user/78954.xls
Habe Zeilen Gelb Markiert die zum beispiel gelöscht sollte werden
Danke und Grüße
Karel
AW: Löschen Code ergänzung
16.02.2012 21:53:49
Josef

Hallo Karel,
der Code sucht ja auch im Blatt "Atribute" und nicht in "T1".

« Gruß Sepp »

Anzeige
AW: Löschen Code ergänzung
16.02.2012 21:52:25
Karel
Hallo Sep
Sorry, ich meinte Tabelle T1, wenn da Zelle im Spalte C leer ist Dan Sollte in Tabelle T1 diese Zeile Gelöscht werde.
Danke und Grüße
Karel
AW: Löschen Code ergänzung
17.02.2012 08:55:10
Karel
Gute Morgen Sepp,
Wie kann der Code so geändert wird sodass auf Tabelle T1 gelöscht wird
Beste grüße,
Karel
AW: Löschen Code ergänzung
17.02.2012 10:16:39
Josef

Hallo Karel,
schreib statt Sheets("Atribute"), Sheets("T1")

« Gruß Sepp »

Anzeige
AW: Löschen Code ergänzung
17.02.2012 12:58:15
Karel
Hallo Sepp,
Das hatte ich schon probiert :-(
Vorgang
- Makro holt erst Daten aus Tabelle Atrributte nach Tabelle T1, soweit so gut
- dan aber sollte in Tabelle T1 bei leere Zelle im Spalte C betreffende Zeile Komplett gelöscht werden.
Mit freundliche Grüße,
Karel
AW: Löschen Code ergänzung
17.02.2012 13:08:29
Josef

Hallo Karel,
dann so.
Sub Worksheet_Activate()
  Dim N As Long
  Dim Dx As Range, rngDel As Range
  Dim Mx As Range
  Dim Col As Integer
  Dim Nx As Range
  Dim Zeile As Long
  Application.ScreenUpdating = False
  With Worksheets("Atribute")
    Set Dx = Worksheets("T1").Range("B2")
    N = .Cells(Rows.Count, 1).End(xlUp).Row
    For Each Nx In .Range("A2:A" & CStr(N))
      Application.StatusBar = Nx.Value
      For Each Mx In .Range("B1:N1")
        Dx.Offset(Col, -1).Value = Nx.Value
        Dx.Offset(Col, 0).Value = Mx.Value
        Dx.Offset(Col, 1).Value = Mx.Offset(Nx.Row - 1, 0).Value
        Col = Col + 1
      Next
    Next
  End With
  
  With Worksheets("T1")
    For Each Nx In .Range("C2:C" & .Cells(.Rows.Count, 3).End(xlUp).Row)
      If Nx = "" Then
        If rngDel Is Nothing Then
          Set rngDel = .Rows(Nx.Row)
        Else
          Set rngDel = Union(rngDel, .Rows(Nx.Row))
        End If
      End If
    Next
  End With
  
  If Not rngDel Is Nothing Then rngDel.Delete
  Application.ScreenUpdating = True
End Sub



« Gruß Sepp »

Anzeige
AW: Löschen Code ergänzung
17.02.2012 14:02:37
Karel
Hallo Sepp,
Vielen dank für deine Lösung und für dein geduld
Schönes Wochende wünsche ich dir
Karel

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige