Microsoft Excel

Herbers Excel/VBA-Archiv

Löschen Code ergänzung | Herbers Excel-Forum


Betrifft: Löschen Code ergänzung von: Karel
Geschrieben am: 16.02.2012 20:33:54

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

  

Betrifft: AW: Löschen Code ergänzung von: Josef Ehrensberger
Geschrieben am: 16.02.2012 21:20:28


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 »



  

Betrifft: AW: Löschen Code ergänzung von: Karel
Geschrieben am: 16.02.2012 21:43:34

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


  

Betrifft: AW: Löschen Code ergänzung von: Josef Ehrensberger
Geschrieben am: 16.02.2012 21:53:49


Hallo Karel,

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




« Gruß Sepp »



  

Betrifft: AW: Löschen Code ergänzung von: Karel
Geschrieben am: 16.02.2012 21:52:25

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


  

Betrifft: AW: Löschen Code ergänzung von: Karel
Geschrieben am: 17.02.2012 08:55:10

Gute Morgen Sepp,

Wie kann der Code so geändert wird sodass auf Tabelle T1 gelöscht wird

Beste grüße,

Karel


  

Betrifft: AW: Löschen Code ergänzung von: Josef Ehrensberger
Geschrieben am: 17.02.2012 10:16:39


Hallo Karel,

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




« Gruß Sepp »



  

Betrifft: AW: Löschen Code ergänzung von: Karel
Geschrieben am: 17.02.2012 12:58:15

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


  

Betrifft: AW: Löschen Code ergänzung von: Josef Ehrensberger
Geschrieben am: 17.02.2012 13:08:29


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 »



  

Betrifft: AW: Löschen Code ergänzung von: Karel
Geschrieben am: 17.02.2012 14:02:37

Hallo Sepp,

Vielen dank für deine Lösung und für dein geduld

Schönes Wochende wünsche ich dir

Karel


Beiträge aus den Excel-Beispielen zum Thema "Löschen Code ergänzung"