Daten aufgrund Kriterien auf verschiedene ....

Bild

Betrifft: Daten aufgrund Kriterien auf verschiedene .... von: Robert
Geschrieben am: 08.02.2005 16:01:32

Hallo,

Hoffentlich könnt ihr mich wieder mal helfen.
Ich habe eine Mappe mit 3 Arbeitsblättern:

Data entry
Standard plan 1
Standard plan 2

Ich möchte dass alle angaben auf dem Arbeitsblatt "Data entry", die in Spalte 5
der Eintrag "standard plan 1" und in Spalte 9 "OK" haben, mittels VBA auf den verschiedene Arbeitsblätter eingefügt werden. Ich habe angefangen mit dem Code hier unten aber leider klappt es nicht so ganz. Zusätzlich hätte ich gerne das Daten vom Arbeitsblatt "Data entry" die kopiert wurden, gelöscht werden.
Könnt Ihr mich vielleicht einen Hinweis geben, wie das ganze anzugehen?

Grüsse

Robert




Sub CopyRows()
Dim iRow As Integer
   
    iRow = 11
    
  Do
      If Worksheets("Data entry").Cells(iRow, 5) = "standard plan 1" And Worksheets("Data entry").Cells(iRow, 9) = "OK" Then
        Rows(iRow).Copy
        Worksheets("Standard plan 1").Select
        Rows("1:1").Select
        Selection.Insert Shift:=xlDown
   
     ElseIf Worksheets("Data entry").Cells(iRow, 5) = "standard plan 2" And Worksheets("Data entry").Cells(iRow, 9) = "OK" Then
        Rows(iRow).Copy
        Worksheets("Standard plan 2").Select
        Rows("1:1").Select
        Selection.Insert Shift:=xlDown
     
            End If
        iRow = iRow + 1
      
   Loop Until IsEmpty(Cells(iRow, 5))
    
  
End Sub

Bild


Betrifft: AW: Daten aufgrund Kriterien auf verschiedene .... von: Josef Ehrensberger
Geschrieben am: 08.02.2005 17:08:05

Hallo Robert!

Sollte es tun!


      
Sub CopyRows()
Dim iRow As Integer, lastRow As Long, s1 As Long, s2 As Long
Dim wksD As Worksheet, wksS1 As Worksheet, wksS2 As Worksheet

Set wksD = Worksheets("Data entry")
Set wksS1 = Worksheets("Standard plan 1")
Set wksS2 = Worksheets("Standard plan 2")


lastRow = IIf(wksD.Range(
"E65536") <> "", 65536, wksD.Range("E65536").End(xlUp).Row)
    
    
    
For iRow = 11 To lastRow
    

      
If LCase(wksD.Cells(iRow, 5)) = "standard plan 1" And _
                        LCase(wksD.Cells(iRow, 9)) = 
"ok" Then
         s1 = s1 + 1
         wksD.Rows(iRow).Cut wksS1.Cells(s1, 1)

      
ElseIf LCase(wksD.Cells(iRow, 5)) = "standard plan 2" And _
                           LCase(wksD.Cells(iRow, 9)) = 
"ok" Then
         s2 = s2 + 1
         wksD.Rows(iRow).Cut wksS2.Cells(s2, 1)

      
End If

      
   
Next
    
  
End Sub 


     Code eingefügt mit Syntaxhighlighter 3.0



Gruß Sepp

P.S.: Rückmeldung nicht vergessen!


Bild


Betrifft: AW: Daten aufgrund Kriterien auf verschiedene .... von: Robert
Geschrieben am: 08.02.2005 21:43:42

Hallo Sepp,

Ich habe ein wenig mit deiner Lösung herum geprobt und bis zu einen gewissen Moment funktioniert das Ganze. Nur habe ich nicht geschrieben habe das die Arbeitsblätter Standard plan 1 & Standard plan 2 immer mehr Daten zugefügt werden, wenn der Code läuft.

Anwender werden immer wieder neue Daten auf Blatt "Data entry" eingeben. Ich möchte also wirklich nur die Zeilen mit erwähnten Kriterien kopiert und nachher vom "Data entry" gelöscht werden. Ich habe dein Code angepasst aber irgendwie klappt es nicht.
Vielleicht weisst du wie mich weiter zu helfen. Ich denke, dass es nicht funktioniert, weil es keine Schleife ist?


Grüsse und danke

Robert




Sub CopyRows()
Dim iRow As Integer, lastRow As Long, s1 As Long, s2 As Long
Dim wksD As Worksheet, wksS1 As Worksheet, wksS2 As Worksheet
Set wksD = Worksheets("Data entry")
Set wksS1 = Worksheets("Standard plan 1")
Set wksS2 = Worksheets("Standard plan 2")
lastRow = IIf(wksD.Range("E65536") <> "", 65536, wksD.Range("E65536").End(xlUp).Row)
    
    
    For iRow = 11 To lastRow
    
      If LCase(wksD.Cells(iRow, 5)) = "standard plan 1" And _
                        LCase(wksD.Cells(iRow, 9)) = "ok" Then
         s1 = s1 + 1
         wksD.Rows(iRow).Copy
         wksS1.Select
         Rows("1:1").Select
            Selection.Insert Shift:=xlDown
            wksD.Rows(iRow).Delete
  
            
            
      ElseIf LCase(wksD.Cells(iRow, 5)) = "standard plan 2" And _
                           LCase(wksD.Cells(iRow, 9)) = "ok" Then
         s2 = s2 + 1
         wksD.Rows(iRow).Copy
         wksS2.Select
         Rows("1:1").Select
            Selection.Insert Shift:=xlDown
            wksD.Rows(iRow).Delete
      End If
      
   Next
    
  
End Sub






Bild


Betrifft: AW: Daten aufgrund Kriterien auf verschiedene .... von: Robert
Geschrieben am: 08.02.2005 21:44:27

Hallo Sepp,

Ich habe ein wenig mit deiner Lösung herum geprobt und bis zu einen gewissen Moment funktioniert das Ganze. Nur habe ich nicht geschrieben habe das die Arbeitsblätter Standard plan 1 & Standard plan 2 immer mehr Daten zugefügt werden, wenn der Code läuft.

Anwender werden immer wieder neue Daten auf Blatt "Data entry" eingeben. Ich möchte also wirklich nur die Zeilen mit erwähnten Kriterien kopiert und nachher vom "Data entry" gelöscht werden. Ich habe dein Code angepasst aber irgendwie klappt es nicht.
Vielleicht weisst du wie mich weiter zu helfen. Ich denke, dass es nicht funktioniert, weil es keine Schleife ist?


Grüsse und danke

Robert




Sub CopyRows()
Dim iRow As Integer, lastRow As Long, s1 As Long, s2 As Long
Dim wksD As Worksheet, wksS1 As Worksheet, wksS2 As Worksheet
Set wksD = Worksheets("Data entry")
Set wksS1 = Worksheets("Standard plan 1")
Set wksS2 = Worksheets("Standard plan 2")
lastRow = IIf(wksD.Range("E65536") <> "", 65536, wksD.Range("E65536").End(xlUp).Row)
    
    
    For iRow = 11 To lastRow
    
      If LCase(wksD.Cells(iRow, 5)) = "standard plan 1" And _
                        LCase(wksD.Cells(iRow, 9)) = "ok" Then
         s1 = s1 + 1
         wksD.Rows(iRow).Copy
         wksS1.Select
         Rows("1:1").Select
            Selection.Insert Shift:=xlDown
            wksD.Rows(iRow).Delete
  
            
            
      ElseIf LCase(wksD.Cells(iRow, 5)) = "standard plan 2" And _
                           LCase(wksD.Cells(iRow, 9)) = "ok" Then
         s2 = s2 + 1
         wksD.Rows(iRow).Copy
         wksS2.Select
         Rows("1:1").Select
            Selection.Insert Shift:=xlDown
            wksD.Rows(iRow).Delete
      End If
      
   Next
    
  
End Sub






Bild


Betrifft: AW: Daten aufgrund Kriterien auf verschiedene .... von: Josef Ehrensberger
Geschrieben am: 08.02.2005 21:51:38

Hallo Robert!

Du hast geschrieben : "Zusätzlich hätte ich gerne das Daten vom Arbeitsblatt "Data entry" die kopiert wurden, gelöscht werden."

Wenn du die Zeilen löschen willst, dann muss man die Schleife (For - Next ist eine Schleife!) von unten nach oben laufen lassen!



      
Sub CopyRows()
Dim iRow As Integer, lastRow As Long, s1 As Long, s2 As Long
Dim wksD As Worksheet, wksS1 As Worksheet, wksS2 As Worksheet

Set wksD = Worksheets("Data entry")
Set wksS1 = Worksheets("Standard plan 1")
Set wksS2 = Worksheets("Standard plan 2")


lastRow = IIf(wksD.Range(
"E65536") <> "", 65536, wksD.Range("E65536").End(xlUp).Row)
    
    
    
For iRow = lastRow To 11 Step -1
    

      
If LCase(wksD.Cells(iRow, 5)) = "standard plan 1" And _
                        LCase(wksD.Cells(iRow, 9)) = 
"ok" Then
         s1 = s1 + 1
         wksD.Rows(iRow).Cut wksS1.Cells(s1, 1)
         wksD.Rows(lRow).Delete

      
ElseIf LCase(wksD.Cells(iRow, 5)) = "standard plan 2" And _
                           LCase(wksD.Cells(iRow, 9)) = 
"ok" Then
         s2 = s2 + 1
         wksD.Rows(iRow).Cut wksS2.Cells(s2, 1)
         wksD.Rows(lRow).Delete

      
End If

      
   
Next
    
  
End Sub 


     Code eingefügt mit Syntaxhighlighter 3.0



Gruß Sepp

P.S.: Rückmeldung nicht vergessen!


Bild


Betrifft: AW: Daten aufgrund Kriterien auf verschiedene .... von: Robert
Geschrieben am: 08.02.2005 22:48:03

Hallo Sepp,

Ich habe mit deiner Hilfe das Problem lösen können. Jetzt, wenn die Kriterien stimmen,
werden Daten von "Data Entry" nach "Standard plan 1" oder "Standard plan 2" eingefügt und Zeilen(rows) von "Data Entry" entfernt, anstatt dass nur Daten gelöscht werden.

Vielen Dank Sepp


Sub CopyRows2()
Dim iRow As Integer, lastRow As Long, s1 As Long, s2 As Long
Dim wksD As Worksheet, wksS1 As Worksheet, wksS2 As Worksheet
Set wksD = Worksheets("Data entry")
Set wksS1 = Worksheets("Standard plan 1")
Set wksS2 = Worksheets("Standard plan 2")
lastRow = IIf(wksD.Range("E65536") <> "", 65536, wksD.Range("E65536").End(xlUp).Row)
    
    
    For iRow = lastRow To 11 Step -1
    
      If LCase(wksD.Cells(iRow, 5)) = "standard plan 1" And _
                        LCase(wksD.Cells(iRow, 9)) = "ok" Then
     
         wksD.Rows(iRow).Copy
         wksS1.Select
         Rows("1:1").Select
            Selection.Insert Shift:=xlDown
            wksD.Rows(iRow).Delete
      ElseIf LCase(wksD.Cells(iRow, 5)) = "standard plan 2" And _
                           LCase(wksD.Cells(iRow, 9)) = "ok" Then
         
         wksD.Rows(iRow).Copy
         wksS2.Select
         Rows("1:1").Select
            Selection.Insert Shift:=xlDown
            wksD.Rows(iRow).Delete
      End If
      
   Next
    
  
End Sub



Bild


Betrifft: AW: Daten aufgrund Kriterien auf verschiedene .... von: Josef Ehrensberger
Geschrieben am: 08.02.2005 22:56:08

Hallo Robert!

Freud mich wenn's klappt!

Hier noch eine Variante ohne das der Cursor wie ein Hund hin und her gehetzt wird ;-))


      
Sub CopyRows()
Dim lRow As Long, lastRow As Long, s1 As Long, s2 As Long
Dim wksD As Worksheet, wksS1 As Worksheet, wksS2 As Worksheet
Dim rng As Range

Set wksD = Worksheets("Data entry")
Set wksS1 = Worksheets("Standard plan 1")
Set wksS2 = Worksheets("Standard plan 2")

On Error GoTo ERRORHANDLER

With Application
.ScreenUpdating = 
False
.EnableEvents = 
False
.DisplayAlerts = 
False
.Calculation = xlCalculationManual
End With

lastRow = IIf(wksD.Range(
"E65536") <> "", 65536, _
            wksD.Range(
"E65536").End(xlUp).Row)
    
    
    
For lRow = 11 To lastRow
    

      
If LCase(wksD.Cells(lRow, 5)) = "standard plan 1" And _
                        LCase(wksD.Cells(lRow, 9)) = 
"ok" Then
         s1 = s1 + 1
         wksD.Rows(lRow).Copy wksS1.Cells(s1, 1)
         
            
If rng Is Nothing Then
            
Set rng = wksD.Rows(lRow)
            
Else
            
Set rng = Union(rng, wksD.Rows(lRow))
            
End If

      
ElseIf LCase(wksD.Cells(lRow, 5)) = "standard plan 2" And _
                           LCase(wksD.Cells(lRow, 9)) = 
"ok" Then
         s2 = s2 + 1
         wksD.Rows(lRow).Copy wksS2.Cells(s2, 1)
         
            
If rng Is Nothing Then
            
Set rng = wksD.Rows(lRow)
            
Else
            
Set rng = Union(rng, wksD.Rows(lRow))
            
End If
         
      
End If

   
Next
    
rng.Delete
  
ERRORHANDLER:

With Application
.ScreenUpdating = 
True
.EnableEvents = 
True
.DisplayAlerts = 
True
.Calculation = xlCalculationAutomatic
End With
End Sub 


     Code eingefügt mit Syntaxhighlighter 3.0



Gruß Sepp


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Daten aufgrund Kriterien auf verschiedene ...."