PDA

Vollständige Version anzeigen : Wenn bestimmter Wert dann komplette Zeile in entsprechendes Datenblatt kopieren


glegio
05.04.2012, 18:23
Hallo Alle

Ich habe folgendes Problem:

Aus dem Datenblatt 'Adress-Daten' soll in Spalte M oder N nach einem bestimmten Wert gesucht werden und die ganze Zeile in das entsprechende Datenblatt kopiert werden.

Ich hab was mit Mokros versucht, aber irgendwie funkts es nicht :(

Bsp.:
In Zelle N3 steht "1. Mannschaft", die ganze Zeile 3, soll in Datenblatt "1. Mannschaft" kopiert werden, jedoch nur bestimmte Spalten. (siehe Beispiel-Datei)

Danke in Voraus für Eure Hilfe

Gruss - Glegio

totti74
05.04.2012, 21:23
Hallo Glegio,
versuch es mal hiermit...

Sub KopierenWennBedingungenErfüllt()
Dim Bereich As Range
Dim zelle As Range

Sheets(1).Range("n2", ActiveSheet.Range("n65536").End(xlUp)).Select

For Each zelle In Selection

If zelle.Value = "Vorstand" Then
zelle.EntireRow.Copy
Sheets(2).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial
End If

If zelle.Value = "1. Mannschaft" Then
zelle.EntireRow.Copy
Sheets(3).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial
End If

If zelle.Value = "2. Mannschaft" Then
zelle.EntireRow.Copy
Sheets(4).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial

End If
Next zelle

End Sub

Die restlichen Mannschaften muß Du natürlich noch ergänzen und vielleicht kann Dir jemand dabei helfen doppelte einträge zu vermeiden.

Gruß
Totti

Backowe
05.04.2012, 22:14
Hi,

probiere es mal so, auf "Select" kann zu 99,9% verzichtet werden!

Sub DatensaetzeKopieren()
Dim lngZeile As Long
For lngZeile = 2 To Sheets("Adressen-Daten").Cells(Rows.Count, "A").End(xlUp).Row
If WorksheetExists(Sheets("Adressen-Daten").Cells(lngZeile, "N")) = False Then
If Application.IsNumber(Application.Match(Sheets("Adressen-Daten").Cells(lngZeile, "A"), _
Sheets("" & Sheets("Adressen-Daten").Cells(lngZeile, "M") & "").Columns(1), 0)) = False Then
With Sheets("" & Sheets("Adressen-Daten").Cells(lngZeile, "M") & "")
Sheets("Adressen-Daten").Range("A" & lngZeile & ":P" & lngZeile).Copy _
Destination:=.Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
End With
End If
Else
If Application.IsNumber(Application.Match(Sheets("Adressen-Daten").Cells(lngZeile, "A"), _
Sheets("" & Sheets("Adressen-Daten").Cells(lngZeile, "N") & "").Columns(1), 0)) = False Then
With Sheets("" & Sheets("Adressen-Daten").Cells(lngZeile, "N") & "")
Sheets("Adressen-Daten").Range("A" & lngZeile & ":P" & lngZeile).Copy _
Destination:=.Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
End With
End If
End If
Next
End Sub

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (Sheets(WorksheetName).Name <> "")
On Error GoTo 0
End Function

glegio
06.04.2012, 13:09
Hallo Ihr zwei

Vielen Dank für die Hilfe.
Habe es mit der Variante von Totti auf meine Original-Datei versucht und wie folgt erweitert:

Sub KopierenWennBedingungenErfüllt()
Dim Bereich As Range
Dim zelle As Range

Sheets(1).Range("n2", ActiveSheet.Range("n65536").End(xlUp)).Select
Sheets(1).Range("m2", ActiveSheet.Range("n65536").End(xlUp)).Select 'ergänzt duch mich

For Each zelle In Selection

If zelle.Value = "Vorstand" Then
zelle.EntireRow.Copy
Sheets(2).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial
End If

If zelle.Value = "Vorstand / Aktiven" Then
zelle.EntireRow.Copy
Sheets(2).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial
End If

If zelle.Value = "1. Mannschaft" Then
zelle.EntireRow.Copy
Sheets(3).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial
End If

If zelle.Value = "2. Mannschaft" Then
zelle.EntireRow.Copy
Sheets(4).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial
End If

If zelle.Value = "3. Mannschaft" Then
zelle.EntireRow.Copy
Sheets(5).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial
End If

If zelle.Value = "Junioren A" Then
zelle.EntireRow.Copy
Sheets(6).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial
End If

If zelle.Value = "Junioren B" Then
zelle.EntireRow.Copy
Sheets(7).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial
End If

If zelle.Value = "Junioren C" Then
zelle.EntireRow.Copy
Sheets(8).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial
End If

If zelle.Value = "Junioren D" Then
zelle.EntireRow.Copy
Sheets(9).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial
End If

If zelle.Value = "Junioren E" Then
zelle.EntireRow.Copy
Sheets(10).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial
End If

If zelle.Value = "Senioren" Then
zelle.EntireRow.Copy
Sheets(11).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial
End If

If zelle.Value = "Veteranen" Then
zelle.EntireRow.Copy
Sheets(12).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial
End If

If zelle.Value = "Passiven" Then
zelle.EntireRow.Copy
Sheets(13).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial
End If

If zelle.Value = "Ehrenmitglied" Then
zelle.EntireRow.Copy
Sheets(14).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial
End If

If zelle.Value = "Sponsor" Then
zelle.EntireRow.Copy
Sheets(15).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial
End If

Next zelle

End Sub

Das Makro funktioniert gut ..fast perfekt, was seltsam ist dass er mir die Werte ab Datenblatt "Senioren" nicht mehr bringt.. d.h. die "Passiven", "Sponsor" und "Ehrenmitglied" nicht liefert resp. kopiert.

Habt Ihr eine Ahnung warum?

**

mit der Variante von Backowe erhalte ich die folgende FM:

"Index ausserhalb des gültigen Bereichs"



..für weitere Hilfe wäre ich Euch sehr dankbar

Gruss - Glegio

glegio
06.04.2012, 13:13
..ausserdem habe ich das Problem, dass wenn das Makro 2,3,4 mal läuft, er mir immerwieder die gleichen Datensätze in die entsprechenden Datenblätter reinkopiert, das bewirkt natürlich, dass ich dann mehrere Zeile habe, die gleich sind.. resp. doppelte..
kann man da sagen: wenn Datensatz bereits existiert, dann Zeile nicht ergänzen?

Vielen Dank - glegio

Backowe
06.04.2012, 16:02
Hi,

in deinem Fall kann ich den "Index ausserhalb des gültigen Bereiches" sogar nachstellen, die FM kommt in Zeile 17, da steht in M17 "Sposor" und das Tabellenblatt heißt "Sponsor". Berichtige den Tippfehler und das Makro läuft ohne Fehler durch. Beim zweiten oder beim x-ten Makrolauf werden keine Datensätze mehrfach in eine Tabelle geschrieben!

Nochmals mein Tip, "Select" ist zu 99,9% unnötig! ;)

glegio
06.04.2012, 17:46
Hallo Jürgen

:) ich bestätige zu 100%, "Select" ist unnötig!!

Ich habe es in der Original-Datei versucht (dort hatte ich kein Vertipper), die FM kommt aber trotzdem :(

Er übernimmt z.T. Datensätze, jedoch nur die, welche in der Spalte M ein Treffer hat..

zb:
Zeile XY hat in der Spalte M Wert "Vorstand / Aktiven" und in Spalte N "Senioren" ..die Zeile wird in Datenblatt "Senioren" korrekt kopiert, jedoch nicht in Datenblatt "Vorstand"..

Zeilen die in Spalte M keine Werte haben und nur in Spalte N (zb Senioren) werden nicht in die entsprechenden Datenblätter "Senioren" etc. kopiert. :-/

Was eben sein kann ist, das ein Mitglied im Vorstand ist aber auch ein Senior ist, da muss der Datensatz in Datenblatt "Vorstand" und "Senioren" kopiert werden.

Ist es Hilfreich, wenn ich Dir die Datei zur Verfügung stelle, und wenn ja, darf ich diese an eine Mailadresse sende?

Gruss und Danke noch mal
- Glegio

Backowe
06.04.2012, 19:45
Hi,

dies ist ein freiwilliges Hilfeforum, Hilfeleistungen sollten öffentlich sein damit die Allgemeinheit etwas davon hat. Sei mir nicht böse, aber ich werde dir meine persönliche eMail-Adresse nicht mitteilen, aus gewissen Gründen auf die ich nicht näher eingehen möchte.

Ich habe dir mal den Code, den ich geschrieben habe, dokumentiert damit du siehst was ich verstanden habe. Du kannst gerne deine Orginaldatei hier einstellen, aber lösche bitte die darin enthaltenen sensitiven Daten. Wenn ich etwas falsch verstanden habe, dann teile es mir bitte mit, je genauer deine Analyse ist, desto schneller kann dir geholfen werden.


Sub DatensaetzeKopieren()

'Variablendeklaration
Dim lngZeile As Long

'Schleife über alle vorhandenen Datensätze ab der Zeile 2
For lngZeile = 2 To Sheets("Adressen-Daten").Cells(Rows.Count, "A").End(xlUp).Row

'Überprüfung des Wertes in der Spalte N ob eine Tabelle mit dem gleichen Namen vorhanden ist,
'wenn nicht wird im Else-Zweig der Wert aus der Spalte M genommen.
If WorksheetExists(Sheets("Adressen-Daten").Cells(lngZeile, "N")) = False Then

'Prüfung existiert die Mitglieds-ID in der entsprechenden Tabelle nicht, dann wird im nächsten
'Schritt der Datensatz in die entsprechende Tabelle in die nächste freie Zeile kopiert.
If Application.IsNumber(Application.Match(Sheets("Adressen-Daten").Cells(lngZeile, "A"), _
Sheets("" & Sheets("Adressen-Daten").Cells(lngZeile, "M") & "").Columns(1), 0)) = False Then

'Kopiervorgang des Datensatzes
With Sheets("" & Sheets("Adressen-Daten").Cells(lngZeile, "M") & "")
Sheets("Adressen-Daten").Range("A" & lngZeile & ":P" & lngZeile).Copy _
Destination:=.Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
End With
End If

Else

'Überprüfung existiert die Mitglieds-ID in der entsprechenden Tabelle nicht, dann wird im nächsten
'Schritt der Datensatz in die entsprechende Tabelle in die nächste freie Zeile kopiert.
If Application.IsNumber(Application.Match(Sheets("Adressen-Daten").Cells(lngZeile, "A"), _
Sheets("" & Sheets("Adressen-Daten").Cells(lngZeile, "N") & "").Columns(1), 0)) = False Then

'Kopiervorgang des Datensatzes
With Sheets("" & Sheets("Adressen-Daten").Cells(lngZeile, "N") & "")
Sheets("Adressen-Daten").Range("A" & lngZeile & ":P" & lngZeile).Copy _
Destination:=.Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
End With
End If
End If
Next
End Sub

'Funktion existiert eine Tabelle mit dem übergebenen Namen.
Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (Sheets(WorksheetName).Name <> "")
On Error GoTo 0
End Function

glegio
07.04.2012, 12:30
Hallo Jürgen

Ich verstehe es vollkommen, und deswegen habe ich eher scheu gefragt, habe nun die Daten mutiert.

Vielen Dank auch für die Kommentare.

Was eben sein kann ist, dass jemand Mitglied einer Gruppe ist (Spalte M) als auch in einer Mannschaft (Spalte N) spielt, so soll diesen Mitglied in Datenblatt X und Y vorkommen.

Ich stelle die komplette Datei hier zur Verfügung, hilft bestimmt fürs bessere Verständnis.

Vielen Dank - Glegio

Backowe
07.04.2012, 15:45
Hi,

bevor ich wieder anfange zu programmieren und alles wieder verworfen wird, frage ich nochmals nach. Ich habe eine Tabelle erstellt mit den Tabellenzuordnungen, wie ich sie verstanden habe. Schaue es dir bitte mal an, ob das so schlüssig ist oder nicht!

glegio
08.04.2012, 09:51
Ciao Jürgen

Ja genau so habe ich mir das vorgestellt, nur dass ich 2 Datenblätter vergessen haben, und zwar "Schiedsrichter" und "Trainerstab" :-/

Gruss Giusi

Backowe
08.04.2012, 12:50
Hi,

ich habe die beiden Tabellenblätter dann noch hinzugefügt, ausserdem war der Index doppelt, schau es dir einfach mal in der mir zur Verfügung gestellten Datei an.

Hier der angepasste Code:


Sub DatensaetzeKopieren()
Dim lngZeile As Long
For lngZeile = 2 To Sheets("Adressen-Daten").Cells(Rows.Count, "A").End(xlUp).Row
If WorksheetExists(Sheets("Adressen-Daten").Cells(lngZeile, "N")) Then
If Application.IsNumber(Application.Match(Sheets("Adressen-Daten").Cells(lngZeile, "A"), _
Sheets("" & Sheets("Adressen-Daten").Cells(lngZeile, "N") & "").Columns(1), 0)) = False Then
With Sheets("" & Sheets("Adressen-Daten").Cells(lngZeile, "N") & "")
Sheets("Adressen-Daten").Range("A" & lngZeile & ":P" & lngZeile).Copy _
Destination:=.Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
End With
End If
End If
If WorksheetExists(Sheets("Adressen-Daten").Cells(lngZeile, "M")) Then
If Application.IsNumber(Application.Match(Sheets("Adressen-Daten").Cells(lngZeile, "A"), _
Sheets("" & Sheets("Adressen-Daten").Cells(lngZeile, "M") & "").Columns(1), 0)) = False Then
With Sheets("" & Sheets("Adressen-Daten").Cells(lngZeile, "M") & "")
Sheets("Adressen-Daten").Range("A" & lngZeile & ":P" & lngZeile).Copy _
Destination:=.Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
End With
End If
End If
If Left(Sheets("Adressen-Daten").Cells(lngZeile, "M"), 10) = "Vorstand /" Then
If WorksheetExists("Vorstand") Then
If Application.IsNumber(Application.Match(Sheets("Adressen-Daten").Cells(lngZeile, "A"), _
Sheets("Vorstand").Columns(1), 0)) = False Then
With Sheets("Vorstand")
Sheets("Adressen-Daten").Range("A" & lngZeile & ":P" & lngZeile).Copy _
Destination:=.Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
End With
End If
End If
End If
Next
End Sub

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (Sheets(WorksheetName).Name <> "")
On Error GoTo 0
End Function

glegio
08.04.2012, 14:09
Hi

Hat einwandfrei funktioniert und weiss nicht wie danken!!
Was ich jetzt aber habe ist, dass wenn wenn datensätze aus dem Hauptblatt entfernt werden, diese in den anderen noch zu sehen sind.. dies ist jedoch nicht schlimm, kann alles löschen und Makro anschliessend starten.

Danke und Gruss - Giusi

werde mich wohl bald wieder melden.. diese Geschtichte gefällt mir nämlich

Backowe
08.04.2012, 15:56
Hi,

das kannst du einfach so lösen, Code kommt in die Tabelle "Adressen-Daten", der zu löschende Datensatz wird in Spalte Q mit einem "x" gekennzeichet!

Bitte an einer Kopie deiner Tabelle testen!


Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
If Not Intersect(Target, Range("Q2:Q" & Cells(Rows.Count, "A").End(xlUp).Row)) Is Nothing And Target.Count = 1 Then
If LCase(Target) = "x" Then
If MsgBox("Wollen Sie wirklich den Datensatz löschen?", vbOKCancel + vbQuestion, "Mitglied löschen") = vbOK Then
For Each ws In Worksheets
If ws.Name <> "Adressen-Daten" Then
If Application.IsNumber(Application.Match(Cells(Target.Row, "A"), ws.Columns(1), 0)) Then
ws.Rows(Application.Match(Cells(Target.Row, "A"), ws.Columns(1), 0)).EntireRow.Delete
End If
End If
Next
Cells(Target.Row, "A").EntireRow.Delete
MsgBox "Datensatz wurde erfolgreich gelöscht!"
Else
Cells(Target.Row, "Q") = ""
End If
End If
End If
End Sub

glegio
08.04.2012, 17:03
:eek: ..jetzt hast du mich definitiv abgehängt, wo wie kann ich ich den code in die Tabelle "Adressen-Daten" eingeben?

resp. wann kommt die Frage ob ich wirklich den Datensatz löschen will?

..ich habs so gemacht: (siehe .jpg) aber wenn ich eine Zeile manuel oder über die Maske lösche passiert nichts?


Habe Q mit S ersetzt da diese Spalten mit "Betrag bezahlt" und "Betrag Forecast" besetzt sind

gruss

Backowe
08.04.2012, 18:04
Hi,

so wie du es eingestellt hast mit der Spalte S, musst du in der Spalte in die betreffende Zeile einfach ein "x" einfügen, dann sollte das Makro automatisch starten und dir die Msgbox anzeigen mit Klick auf "Ok" wird dann in jeder Tabelle der entsprechende Datensatz gelöscht!

glegio
10.04.2012, 13:29
..wie hätte es anders sein können, es funktioniert natürlich einwandfrei!!

mille grazie Jürgen!!

glegio
10.04.2012, 15:58
Habe den Button "Löschen" der Eingabemaske mit dem Code:

'löscht Datensatz "Person löschen"
Private Sub CommandButton1_Click()
Dim xZeile As Long
If TextBox1 = "" Then Exit Sub
If ComboBox1.ListIndex = 0 Then
xZeile = [A65536].End(xlUp).Row + 1
Else
xZeile = ComboBox1.ListIndex + 1
End If
Cells(xZeile, 1) = TextBox1
Cells(xZeile, 2) = TextBox2
Cells(xZeile, 3) = TextBox3
Cells(xZeile, 4) = TextBox4
Cells(xZeile, 5) = TextBox5
Cells(xZeile, 6) = TextBox6
Cells(xZeile, 7) = ComboBox5
Cells(xZeile, 8) = TextBox8
Cells(xZeile, 9) = TextBox9
Cells(xZeile, 10) = TextBox10
Cells(xZeile, 11) = TextBox11
Cells(xZeile, 12) = TextBox12
Cells(xZeile, 13) = ComboBox2
Cells(xZeile, 14) = ComboBox3
Cells(xZeile, 15) = ComboBox4
Cells(xZeile, 16) = ComboBox6
Cells(xZeile, 17) = "x"
TextBox1 = ""
TextBox2 = ""
TextBox3 = ""
TextBox4 = ""
TextBox5 = ""
TextBox6 = ""
ComboBox5 = ""
TextBox8 = ""
TextBox9 = ""
TextBox10 = ""
TextBox11 = ""
TextBox12 = ""
ComboBox2 = ""
ComboBox3 = ""
ComboBox4 = ""
ComboBox6 = ""
Columns("A:Q").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
UserForm_Initialize
End Sub


der soll in Spalte Q das "x" schreiben, welche dann den folgenden Makro auslöst:


Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
If Not Intersect(Target, Range("Q2:Q" & Cells(Rows.Count, "A").End(xlUp).Row)) Is Nothing And Target.Count = 1 Then
If LCase(Target) = "x" Then
If MsgBox("Wollen Sie wirklich den Datensatz löschen?", vbOKCancel + vbQuestion, "Mitglied löschen") = vbOK Then
For Each ws In Worksheets
If ws.Name <> "Adressen-Daten" Then
If Application.IsNumber(Application.Match(Cells(Target.Row, "A"), ws.Columns(1), 0)) Then
ws.Rows(Application.Match(Cells(Target.Row, "A"), ws.Columns(1), 0)).EntireRow.Delete
End If
End If
Next
Cells(Target.Row, "A").EntireRow.Delete
MsgBox "Datensatz wurde erfolgreich gelöscht!"
Else
Cells(Target.Row, "Q") = ""
End If
End If
End If
End Sub


das funktioniert auch alles super, sperre ich jedoch in allen Datenblätter die Zellen A1:Q1, kommt der Laufzeitfehler 1004 und das Debuggen zeigt die Zeile:

Columns("A:Q").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

an.

Backowe
10.04.2012, 17:43
Hi,

hier mal eine Quick and Dirty Lösung, ist ungetestet!

Range("A2:Q" & Cells(Rows.Count, "A").End(xlUp).Row).Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

glegio
11.04.2012, 07:41
;) jo.. klar funkts!

Danke Jürgen, werde das File nach dir benennen!!

glegio
14.04.2012, 13:23
eine Frage habe jetzt doch noch gefunden.. :-/

wie kann die Zeile die in den Datenblätter kopiert wird, resp im die neue Zeile die ins Hauptdatenblat 'Adressen-Daten' ergänzt wird, so formatiert werden wie z.B. Zeile 2? ..und das dann auch so in den anderen Datenbläter übernommen werden?

Backowe
14.04.2012, 21:36
Hi,

hoffe das passt so, ich habe in das Klassenmodul "Adressen-Daten" noch eine kleine Änderung eingebaut und die Bezüge kontrollieren, bitte beachten!

allgemeines Modul:


Sub DatensaetzeKopieren()
Dim lngZeile As Long
EreignisseAus
For lngZeile = 2 To Sheets("Adressen-Daten").Cells(Rows.Count, "A").End(xlUp).Row
If WorksheetExists(Sheets("Adressen-Daten").Cells(lngZeile, "N")) Then
If Application.IsNumber(Application.Match(Sheets("Adressen-Daten").Cells(lngZeile, "A"), _
Sheets("" & Sheets("Adressen-Daten").Cells(lngZeile, "N") & "").Columns(1), 0)) = False Then
With Sheets("" & Sheets("Adressen-Daten").Cells(lngZeile, "N") & "")
Sheets("Adressen-Daten").Range("A" & lngZeile & ":P" & lngZeile).Copy _
Destination:=.Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
Sheets("Adressen-Daten").Range("A2:P2").Copy
.Range(.Cells(.Cells(Rows.Count, "A").End(xlUp).Row, "A"), .Cells(.Cells(Rows.Count, "A").End(xlUp).Row, "P")).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Application.GoTo .Range("A1"), Scroll:=True
.Columns("A:P").AutoFit
End With
End If
End If
If WorksheetExists(Sheets("Adressen-Daten").Cells(lngZeile, "M")) Then
If Application.IsNumber(Application.Match(Sheets("Adressen-Daten").Cells(lngZeile, "A"), _
Sheets("" & Sheets("Adressen-Daten").Cells(lngZeile, "M") & "").Columns(1), 0)) = False Then
With Sheets("" & Sheets("Adressen-Daten").Cells(lngZeile, "M") & "")
Sheets("Adressen-Daten").Range("A" & lngZeile & ":P" & lngZeile).Copy _
Destination:=.Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
Sheets("Adressen-Daten").Range("A2:P2").Copy
.Range(.Cells(.Cells(Rows.Count, "A").End(xlUp).Row, "A"), .Cells(.Cells(Rows.Count, "A").End(xlUp).Row, "P")).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Application.GoTo .Range("A1"), Scroll:=True
.Columns("A:P").AutoFit
End With
End If
End If
If Left(Sheets("Adressen-Daten").Cells(lngZeile, "M"), 10) = "Vorstand /" Then
If WorksheetExists("Vorstand") Then
If Application.IsNumber(Application.Match(Sheets("Adressen-Daten").Cells(lngZeile, "A"), _
Sheets("Vorstand").Columns(1), 0)) = False Then
With Sheets("Vorstand")
Sheets("Adressen-Daten").Range("A" & lngZeile & ":P" & lngZeile).Copy _
Destination:=.Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
Sheets("Adressen-Daten").Range("A2:P2").Copy
.Range(.Cells(.Cells(Rows.Count, "A").End(xlUp).Row, "A"), .Cells(.Cells(Rows.Count, "A").End(xlUp).Row, "P")).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Application.GoTo .Range("A1"), Scroll:=True
.Columns("A:P").AutoFit
End With
End If
End If
End If
Next

EreignisseEin
End Sub

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (Sheets(WorksheetName).Name <> "")
On Error GoTo 0
End Function

Sub EreignisseAus()
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
End Sub

Sub EreignisseEin()
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


Klassenmodul der Tabelle "Adressen-Daten":


Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
If Not Intersect(Target, Range("S2:S" & Cells(Rows.Count, "A").End(xlUp).Row)) Is Nothing And Target.Count = 1 Then
EreignisseAus
If LCase(Target) = "x" Then
If MsgBox("Wollen Sie wirklich den Datensatz löschen?", vbOKCancel + vbQuestion, "Mitglied löschen") = vbOK Then
For Each ws In Worksheets
If ws.Name <> "Adressen-Daten" Then
If Application.IsNumber(Application.Match(Cells(Target.Row, "A"), ws.Columns(1), 0)) Then
ws.Rows(Application.Match(Cells(Target.Row, "A"), ws.Columns(1), 0)).EntireRow.Delete
End If
End If
Next
Cells(Target.Row, "A").EntireRow.Delete
MsgBox "Datensatz wurde erfolgreich gelöscht!"
Else
Cells(Target.Row, "S") = ""
End If
End If
End If
EreignisseEin
End Sub

Thomas Ramel
15.04.2012, 08:22
Grüezi zusammen

Ganz ohne individuelle Programmierung kann das meiner Ansicht nach mit der folgenden Mappe getan werden.

http://users.quick-line.ch/ramel/Files/spezialfilter_automatisiert-neu.xls

Füge ins erste Tabellenblatt deine Daten ein wie es in den Hinweisen in der Mappe beschrieben wird.

Lösche dann alle Blätter bis auf die ersten beiden.

Füge im Blatt 2 in Zeile 1 deine Spaltenüberschriften aus Blatt 1 1:1 ein, leere den Inhalt der Zeile 2 und gib in der entsprechenden Spalte dein Filter-Kriterium ein.

Kopiere dann Blatt 2 so oft wie benötigt und passe jeweils den Namen des Kriteriums an.

glegio
15.04.2012, 10:37
Funkt soweit gut, vielen Dank.

..nur in Hauptdatenblatt 'Adressen-Daten' wird die Formatierung nicht übernommen wenn ich Datensatz 0501 anlege (Formatiert habe ich nur bis 0500 resp. bis Zeile 501)

..und nach dem Kopieren wird das Hauptdatenblatt 'Adressen-Daten' nicht aktiv, d.h. das erste Datenblatt in welchen die Daten kopiert werden bleibt aktiv..

muss ich den folgenden Code:

Sheets("Adressen-Daten").Range("A2:P2").Copy
.Range(.Cells(.Cells(Rows.Count, "A").End(xlUp).Row, "A"), .Cells(.Cells(Rows.Count, "A").End(xlUp).Row, "P")).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Application.GoTo .Range("A1"), Scroll:=True
.Columns("A:P").AutoFit


auch in:


'schreibt die Daten mit Klick auf Button "Übernehmen"
Private Sub CommandButton2_Click()
ActiveSheet.Unprotect Password:="xxx"
Dim xZeile As Long
If TextBox1 = "" Then Exit Sub
If ComboBox1.ListIndex = 0 Then
xZeile = [A65536].End(xlUp).Row + 1
Else
xZeile = ComboBox1.ListIndex + 1
End If
Cells(xZeile, 1) = TextBox1
Cells(xZeile, 2) = TextBox2
Cells(xZeile, 3) = TextBox3
Cells(xZeile, 4) = TextBox4
Cells(xZeile, 5) = TextBox5
'..usw


implementieren?

Gruss

glegio
15.04.2012, 10:39
Hallo Thomas

Auch Dir danke für deine Hilfe, das Werk ist jedoch praktisch schon fertig.
Gruss - glegio

Backowe
15.04.2012, 10:50
Hi,

das könntest Du so implementieren:


With Sheets("Adressen-Daten")
.Range("A2:P2").Copy
.Range(.Cells(.Cells(Rows.Count, "A").End(xlUp).Row, "A"), .Cells(.Cells(Rows.Count, "A").End(xlUp).Row, "P")).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Application.GoTo .Range("A1"), Scroll:=True
.Columns("A:P").AutoFit
End With

glegio
20.04.2012, 12:12
Hallo

Mutiere ich zb einen bestehenden Datensatz in Hauptdatenblatt 'Adressen-Daten', wird diese Mutation in den anderen Datenbläter nicht nachgeführt.
Kann man den Code so erweitern, dass bei einer Mutation dieser nachschaut ob ein Datensatz (zb denn Wert in Spalte A als Basis nimmt) in den entsprechenden Datenbläter bereis vorhanden ist und wenn ja, dann dieser ersetzt oder sogar gelöscht wird, sofern sich der Datensatzsatz so mutiert hat, dass er nicht mehr in dem Datenblatt gehört wo er ursprünglich war?(zb dann wenn ein Mitglieder von der 1. in 2. Mannschaft wechselt)

Danke und gruss

Thomas Ramel
20.04.2012, 12:47
Grüezi glegio

Wenn ich nochmal auf meine Datei hinweisen darf; damit ist auch dieser Punkt gegeben wenn mich nicht alles täuscht.

glegio
20.04.2012, 18:57
Hallo Thomas

es funkt fast perfekt.. aber nicht genau das was ich am "20.04.2012, 13:12 " beschrieben habe, zb schreibt er des mutierte Datensatz neu in die entsprechende Degenblätter, löscht den Datensatz in den "alte" alten Datenblätter nicht.. auch Korrekturen dated er nicht up. :-/

Thomas Ramel
20.04.2012, 19:44
Grüezi glegio

Hmmm, in meiner Mappe ist alles vorbereitet, da musst Du keinen Code verändern oder anpassen sondern nur deine Daten wie beschrieben reinkopieren und die Filter-Kriterien in Blatt 2 und den folgenden, die Du aus Blatt2 kopieren kannst, anpassen.

Das ist alles, mehr ist nicht zu tun.

Wo bist Du dabei denn auf Probleme gestossen?

glegio
20.04.2012, 20:04
Sorry Thomas.. habe nach dem Posten weiter ausprobiert.. und habs zum laufen gebracht :-) ..bis auf die Updates und Löschungen resp. Verschiebungen funkt alles sehr gut

glegio
20.04.2012, 20:28
Hallo Thomas

Habe mein Post geändert, weil ich nach dem posten es weiter versucht habe.. und habs soweit gebracht, sprich die Datensätze wurden kopiert.. updates werden jedoch nicht gemacht.. auch „alte“ Einträge werden nicht gelöscht..
Ich lade mal eine Kopie hoch

glegio
20.04.2012, 21:52
hab die datei abgespeckt, bekomme sie aber nit schmalgenug um sie zu laden:upps: