Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
560to564
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
560to564
560to564
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Daten aufgrund Kriterien auf verschiedene ....

Daten aufgrund Kriterien auf verschiedene ....
08.02.2005 16:01:32
Robert
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

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Daten aufgrund Kriterien auf verschiedene ....
08.02.2005 17:08:05
Josef
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 


Gruß Sepp
P.S.: Rückmeldung nicht vergessen!
Anzeige
AW: Daten aufgrund Kriterien auf verschiedene ....
08.02.2005 21:43:42
Robert
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


Anzeige
AW: Daten aufgrund Kriterien auf verschiedene ....
08.02.2005 21:44:27
Robert
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


Anzeige
AW: Daten aufgrund Kriterien auf verschiedene ....
08.02.2005 21:51:38
Josef
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 


Gruß Sepp
P.S.: Rückmeldung nicht vergessen!
Anzeige
AW: Daten aufgrund Kriterien auf verschiedene ....
08.02.2005 22:48:03
Robert
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

Anzeige
AW: Daten aufgrund Kriterien auf verschiedene ....
08.02.2005 22:56:08
Josef
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 


Gruß Sepp
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige