Hallo
ich möchte aus einer Tabelle in der ich Inhalte einer Zelle nach (offen, in klärung, umsetzbar) bezeichnen kann, Inhaltsbedingt Zeilen in ein andere Tabelle kopieren.
Beispiel
R1 hose grün umsetzbar
R2 rock rot in klärung
Hier soll nun R1 in die Tabelle umsetzbar kopiert, R2 in Tabelle in Klarüng kopiert werden.
Hier ist der Code
Sub Kopiere_Daten()
'Kopiere_Daten 7.5.08 von Hermann Hehn
Dim Wohin, zbez
Dim Leer
Dim x, y, z
Application.ScreenUpdating = False
Worksheets("umsetzbar").Range("A1:z200").ClearContents
Worksheets("offen").Range("A1:z200").ClearContents
Worksheets("in Klärung").Range("A1:z200").ClearContents
'Verteile Header
'kopiere Reihe 3 und 4
Rows("3:4").Select
Selection.Copy
'Gehe in die 3 Sheets und füge die Überschriften ein
Sheets("Umsetzbar").Select
Rows("1:1").Select
ActiveSheet.Paste
Sheets("Offen").Select
Rows("1:1").Select
ActiveSheet.Paste
Sheets("In Klärung").Select
Rows("1:1").Select
ActiveSheet.Paste
Sheets("Backup").Select
Rows("1:1").Select
ActiveSheet.Paste
' Sheets("Tabelle1").Select
' Rows("1:1").Select
' ActiveSheet.Paste
'Verteile Daten
'gib den Variablen irgend einen Wert
y = 1
z = 20
'Suche die erste freie Reihe
Sheets("NGF-TPM-ZW-Auftragsliste").Select
Range("A4").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
z = ActiveCell.Row
For x = 5 To z
Sheets("NGF-TPM-ZW-Auftragsliste").Select
Cells(x, 6).Select
Wohin = ActiveCell.Value
'lese wert aus zelle
'markiere reihe x
Rows(x).Select
Application.CutCopyMode = False
Selection.Copy
If Wohin = "" Then Exit For
'ab hier pasten
Sheets(Wohin).Select
'find next empty row
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
y = ActiveCell.Row
Sheets(Wohin).Rows
.Select
ActiveSheet.Paste
Next x
Sheets("NGF-TPM-ZW-Auftragsliste").Select
Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub
ich möchte aus einer Tabelle in der ich Inhalte einer Zelle nach (offen, in klärung, umsetzbar) bezeichnen kann, Inhaltsbedingt Zeilen in ein andere Tabelle kopieren.
Beispiel
R1 hose grün umsetzbar
R2 rock rot in klärung
Hier soll nun R1 in die Tabelle umsetzbar kopiert, R2 in Tabelle in Klarüng kopiert werden.
Hier ist der Code
Sub Kopiere_Daten()
'Kopiere_Daten 7.5.08 von Hermann Hehn
Dim Wohin, zbez
Dim Leer
Dim x, y, z
Application.ScreenUpdating = False
Worksheets("umsetzbar").Range("A1:z200").ClearContents
Worksheets("offen").Range("A1:z200").ClearContents
Worksheets("in Klärung").Range("A1:z200").ClearContents
'Verteile Header
'kopiere Reihe 3 und 4
Rows("3:4").Select
Selection.Copy
'Gehe in die 3 Sheets und füge die Überschriften ein
Sheets("Umsetzbar").Select
Rows("1:1").Select
ActiveSheet.Paste
Sheets("Offen").Select
Rows("1:1").Select
ActiveSheet.Paste
Sheets("In Klärung").Select
Rows("1:1").Select
ActiveSheet.Paste
Sheets("Backup").Select
Rows("1:1").Select
ActiveSheet.Paste
' Sheets("Tabelle1").Select
' Rows("1:1").Select
' ActiveSheet.Paste
'Verteile Daten
'gib den Variablen irgend einen Wert
y = 1
z = 20
'Suche die erste freie Reihe
Sheets("NGF-TPM-ZW-Auftragsliste").Select
Range("A4").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
z = ActiveCell.Row
For x = 5 To z
Sheets("NGF-TPM-ZW-Auftragsliste").Select
Cells(x, 6).Select
Wohin = ActiveCell.Value
'lese wert aus zelle
'markiere reihe x
Rows(x).Select
Application.CutCopyMode = False
Selection.Copy
If Wohin = "" Then Exit For
'ab hier pasten
Sheets(Wohin).Select
'find next empty row
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
y = ActiveCell.Row
Sheets(Wohin).Rows

ActiveSheet.Paste
Next x
Sheets("NGF-TPM-ZW-Auftragsliste").Select
Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub
Zuletzt bearbeitet: