Einfaches VBA Makro Zeilen kopieren wenn...

[Alexcel]

Hallo Ihr Lieben,

ich möchte Zeilen kopieren, wenn eine gewisse Bedingung erfüllt wird. Das klappt auch bereits super mit folgendem Makro:

Code:

Public Sub Zeilen2()
Dim i As Integer
Dim cell As Range
i = 1
For Each cell In Tabelle1.Range("C:C")
If Not cell Is Nothing Then
    If cell.Value >= "80" Then
        cell.EntireRow.Copy Destination:=Tabelle2.Rows(i)
        i = i + 1
    End If
End If
Next cell
End Sub

Wie kann ich hier ein zweites Makro einbauen bzw. eine zweite Schleife, nämlich, dass Werte zwischen 30-50% in Tabelle 3 kopiert werden und weitere Werte in Tabelle 4 und 5. Dies wäre ja eine weitere For-Funktion.

Versuch:

Code:

Public Sub Zeilen2()
Dim i As Integer
Dim cell As Range
i = 1
For Each cell In Tabelle1.Range("C:C")
If Not cell Is Nothing Then
   If cell.Value >= "80" Then
       cell.EntireRow.Copy Destination:=Tabelle3.Rows(i)
       i = i + 1
If Not cell Is Nothing Then
   End If
End If
   If cell.Value > "50" And cell.Value <= "79" Then
       cell.EntireRow.Copy Destination:=Tabelle2.Rows(i)
       i = i + 1
   End If
End If

For Each cell In Tabelle1.Range("I:I")
If Not cell Is Nothing Then
   If cell.Value >= "80" Then
       cell.EntireRow.Copy Destination:=Tabelle5.Rows(i)
       i = i + 1
If Not cell Is Nothing Then
   End If
End If
   If cell.Value > "50" And cell.Value <= "79" Then
       cell.EntireRow.Copy Destination:=Tabelle4.Rows(i)
       i = i + 1
   End If
End If


Next cell
End Sub

Das klappt leider nicht Und besteht weiterhin die Möglichkeit bei jedem Makro-Start alle Inhalt des Tabellenblattes zu löschen, weil sonst werden ja nur immer wieder Zeilen hinzugefügt.

Danke für Eure Hilfe im Voraus.

MfG
Alex

[Kuwer]

Hallo Alex,

Public Sub ZeilenKopieren()
 Dim iT2 As Long, iT3 As Long
 Dim rngC As Range
 For Each rngC In Tabelle1.Range("C:C")
   Select Case rngC.Value
     Case ""
       Exit For
     Case Is > 79
       iT2 = iT2 + 1
       rngC.EntireRow.Copy Destination:=Tabelle2.Rows(iT2)
     Case Is > 50
       iT3 = iT3 + 1
       rngC.EntireRow.Copy Destination:=Tabelle3.Rows(iT3)
   End Select
 Next rngC
End Sub

Und besteht weiterhin die Möglichkeit bei jedem Makro-Start alle Inhalt des Tabellenblattes zu löschen, weil sonst werden ja nur immer wieder Zeilen hinzugefügt.

   

Gruß Uwe

[Alexcel]

Vielen Dank für deine megaschnelle Hilfe.

Das Makro funktioniert super! Auf Tabellenblatt 1 habe ich in der ersten Zeile Überschriften. Die übernimmt er für das Tabellenblatt mit den Risikos über 79%. Bei den 50-80% übernimmt er diese nicht. Ist dies noch zu verbessern? Weiterhin besteht die Frage, wie ich das Makro ausweiten kann, um mit Werten von Spalte I:I wieder genau dasselbe für andere Tabellenblätter zu machen.

Mit meiner Frage bezüglich des Löschens meinte ich: Wenn ich jetzt das Makro starte, fügt er von Tabellenblatt 1 Zeilen in Tabellenblatt 2. Fügt man jetzt allerdings andere Ausgangsdaten in Tabellenblatt 1 ein, so bleibt Tabellenblatt 2 bestehen. Mein Anliegen ist es daher, dass sich mit Ausführen des Makros alle Daten von Tabellenblatt 2-5 löschen und diese neu hinzugefügt werden, um alte Werte zu verhindern, also immer aktuell zu bleiben.

Danke!

[Kuwer]

Hallo Alex,

Public Sub ZeilenKopieren()
  Dim iT2 As Long, iT3 As Long
  Dim rngC As Range
  
  Tabelle2.UsedRange = ""
  iT2 = 1
  Tabelle1.Rows(1).Copy Tabelle2.Rows(iT2)
  
  Tabelle3.UsedRange = ""
  iT3 = 1
  Tabelle1.Rows(1).Copy Tabelle3.Rows(iT3)
  
  For Each rngC In Tabelle1.Range("C:C")
    Select Case rngC.Value
      Case ""
        Exit For
      Case Is > 79
        iT2 = iT2 + 1
        rngC.EntireRow.Copy Destination:=Tabelle2.Rows(iT2)
      Case Is > 50
        iT3 = iT3 + 1
        rngC.EntireRow.Copy Destination:=Tabelle3.Rows(iT3)
    End Select
  Next rngC
  
  '--------------------------------------------------------
  
  Tabelle4.UsedRange = ""
  iT2 = 1
  Tabelle1.Rows(1).Copy Tabelle4.Rows(iT2)
  
  Tabelle5.UsedRange = ""
  iT3 = 1
  Tabelle1.Rows(1).Copy Tabelle5.Rows(iT3)
  
  For Each rngC In Tabelle1.Range("I:I")
    Select Case rngC.Value
      Case ""
        Exit For
      Case Is > 79
        iT2 = iT2 + 1
        rngC.EntireRow.Copy Destination:=Tabelle4.Rows(iT2)
      Case Is > 50
        iT3 = iT3 + 1
        rngC.EntireRow.Copy Destination:=Tabelle5.Rows(iT3)
    End Select
  Next rngC
End Sub

Gruß Uwe

[Alexcel]

Nochmals vielen lieben Dank!

Muss mich unbedingt in VBA einlesen.

Nun ist das "Problem" (nein, kein wirkliches Problem, meckern auf sehr hohem Niveau), dass ich die Überschriften in den Tabellenblättern mit über 80% doppelt vorhanden sind, also in Zeile 1 und 2. Ist dies noch leicht auszumerzen? Ansonsten ist es auch nicht schlimm.

[Kuwer]

Hallo Alex,

ändere jeweils so, um die Anzahl Überschriftszeilen flexibel zu gestalten:

  Tabelle2.UsedRange = ""
 iT2 = 1 'Überschrift hat 1 Zeile
 Tabelle1.Rows(1).Resize(iT2).Copy Tabelle2.Rows(1)
 
 Tabelle2.UsedRange = ""
 iT2 = 2 'Überschrift hat 2 Zeilen
 Tabelle1.Rows(1).Resize(iT2).Copy Tabelle2.Rows(1)

Gruß Uwe

[Alexcel]

Jetzt habe ich in einem von den beiden Blättern eine Leerzeile. Das macht aber nichts! Danke.

[Kuwer]

Jetzt habe ich in einem von den beiden Blättern eine Leerzeile. Das macht aber nichts! Danke.

Dann hast Du leider meinen Lösungsvorschlag komplett nicht verstanden. Betonung liegt auf jeweils.

Gruß Uwe

[Alexcel]

Dann hast Du leider meinen Lösungsvorschlag komplett nicht verstanden. Betonung liegt auf jeweils.

Gruß Uwe

Das stimmt leider. Ich kenne mich mit den Begrifflichkeiten leider noch nicht aus und verstehe daher nicht genau, was ich machen soll. Was meinst du mit Überschrift hat eine Zeile?  Wieso immer CopyTabelle2? Danke!

[Kuwer]

Was meinst du mit Überschrift hat eine Zeile?  Wieso immer CopyTabelle2? Danke!

weil ich Dir am Beispiel von Ziel-Tabelle2 zeigen wollte, dass Du mit iT2 = Anzahl Überschriftzeilen als Zahl alle Zieltabellen nach diesem beispielhaften Muster entsprechend einstellen kannst. Ich hatte das also einmal für  eine Zeile und einmal für zwei Zeilen dargestellt. Damit, dass gerade das Dich überfordert, hatte ich nun nicht gerechnet.  

Gruß Uwe