Marko anpassen für Datenübertragung in anderes Tabellenblatt ...

Question

Guten Morgen,

dank fleissiger Hilfe hier www.supportnet.de/t/2222004 habe ich für meine Tabelle ein Makro, dieses überträgt bestimmte Werte in ein anderes Tabellenblatt.
Nun möchte ich dieses Makro um eine Abfrage erweitern - leider ohne Erfolg - und hoffe nochmals auf Eure Hilfe.

Im Moment passiert folgendes:
Blatt Behandlungen: hierhin werden die Datensätze übertragen

In den Blättern 1 bis 100: wird in Spalte 11 eine Änderung vorgenommen, so werden die Daten wie folgt übertragen (die Datensätze werden in dem Blatt Behandlungen in der nächst freien Zeile angehängt):
I3 in A
I4 in B
I5 in C
B bis H werden in D bis J übertragen

Der Code zur zeit:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Application.EnableEvents = False
If Target.Column = 11 Then
With ThisWorkbook.Worksheets(Sh.Index)
ThisWorkbook.Worksheets "Behandlungen").Unprotect
zeile = ThisWorkbook.Worksheets("Behandlungen").Range("A" & Rows.Count).End(xlUp).Row + 1
ThisWorkbook.Worksheets("Behandlungen").Range("A" & zeile) = .Range("I3")
ThisWorkbook.Worksheets("Behandlungen").Range("B" & zeile) = .Range("I4")
ThisWorkbook.Worksheets("Behandlungen").Range("C" & zeile) = .Range("I5")
.Range("B" & Target.Row & ":H" & Target.Row).Copy
ThisWorkbook.Worksheets("Behandlungen").Range("D" & zeile).PasteSpecial Paste:=xlValues, Operation:=xlNone
End With
ThisWorkbook.Worksheets("Behandlungen").Protect
Application.CutCopyMode = False
End If
Application.EnableEvents = True
End Sub

Ich möchte nun folgendes erreichen:
1. wird in Spalte 11 (K) ein x gesetzt, so sollen die Daten übertragen werden (im Moment werden die Daten auch dann übertragen, wenn wegen Fehleingabe x gelöscht wird)
2. ist in Spalte A der Wert "SN" so sollen die Daten in das Blatt Behandlungen übertragen werden
3. ist in Spalte A der Wert "GW", so sollend die Daten in das Blatt Behandlungen-GW übertragen werden

zu 1. wie soll ich x als Gültigkeit überprüfen?
If Target.Column(11) = "x" Then ... -> ergibt Fehlermeldung
zu 1.+2.: If.Cells(1) ="SN" Then ???

Kann mir jemand bei der Lösung helfen ???

Viele Grüße
Petra

Answer 1

... noch eine Anmerkung zu oben:

Ich schrieb:

In den Blättern 1 bis 100:

Dabei handelt es sich um Tabellenblätter, die entsprechend bezeichnet sind, also: das 5. Blatt heiss 1, das 6. Blatt heiss 2, usw.
in Zukunft weren noch mehr Blätter hinzukommen.

Gruss - Petra

Answer 2

Hallo Petra,

aus Zeitmangel kann ich Dir im Moment nur auf Deine Teilfragen antworten

zu 1. wie soll ich x als Gültigkeit überprüfen?
If Target.Column(11) = "x" Then ... -> ergibt Fehlermeldung

...müsste so funktionieren

If Cells(Target.Row, 11).Value = "x" Then.....

zu 1.+2.: If.Cells(1) ="SN" Then ???

...müsste so funktionieren

If Cells(Target.Row, 1).Value = "SN" Or Cells(Target.Row, 1).Value = "GW" Then ....

Gruß
Rainer

Answer 3

hi :-))

dann mal ein beispiel,was leicht zu ergaenzen ist :-))

gruss nighty

die zeilen die zur zeit SN bzw GW betreffen zeigen dir was bei neuen tabellen zu ergaenzen waere(If zeile kopieren/einfuegen/korrigieren/fertig,fuer neue tabelle)

einzufuegen
alt+f11/projektexplorer/DeineArbeitsmappe

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Column = 11 And UCase(Sh.Cells(Target.Row, Target.Column)) = "X" And Target.Cells.Count = 1 Then
Dim ZielTabelle As String
Application.EnableEvents = False
If UCase(Sh.Cells(Target.Row, 1)) = "SN" Then ZielTabelle = "Behandlungen"
If UCase(Sh.Cells(Target.Row, 1)) = "GW" Then ZielTabelle = "Behandlungen -GW"
If SheetExists("" & ZielTabelle) = True Then
Sh.Rows(Target.Row).Copy
Worksheets(ZielTabelle).Range("A" & Worksheets(ZielTabelle).Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
Sh.Rows(Target.Row & ":" & Target.Row).Delete Shift:=xlUp
Else
MsgBox "Tabelle " & ZielTabelle & " gibt es nicht,Vorgang wird abgebrochen"
End If
Application.CutCopyMode = False
Application.EnableEvents = True
End If
End Sub

einzufuegen
alt+f11/projektexplorer/AllgemeinesModul

Public Function SheetExists(strName As String) As Boolean
On Error Resume Next
SheetExists = Not Worksheets(strName) Is Nothing
End Function

Answer 4

@ Rainer:

If Cells(Target.Row, 11).Value = "x" Then.....

Ist perfekt ;-)

If Cells(Target.Row, 1).Value = "SN" Or Cells(Target.Row, 1).Value = "GW" Then

Naja.. muss nochmals nachlesen mit If und OR

Habe nun folgendes gemacht:
If ...="SN"
.....
End If

If ... ="GW"
....
End If

Nicht besonders elegant, funktioniert aber.


@Nighty:
Leider funktioniert das Makro bei mir nicht, habe den Fehler noch nicht gefunden (es tut sich gar nichts).

Ich schaue es mir morgen nochmals (im ausgeschlafenen Zustand) an.

Vielen Dank ... ich melde mich hierauf nochmals ;-)

Gruss - Petra

Answer 5

hi petra und all :-)

ein paar infos vielleicht :-))

gruss nighty

If Target.Column = 11 And UCase(Sh.Cells(Target.Row, Target.Column)) = "X" And Target.Cells.Count = 1 Then

was sagt uns die obige zeile

spalte 11

Target.Column = 11

eine und verknuepfung

And

wandlung in grossbuchstaben,daher ist es nun ohne belang ob klein oder gross

UCase(Sh.Cells(Target.Row, Target.Column))

die und verknuepfung erwartet ein grosses X in spalte 11

And UCase(Sh.Cells(Target.Row, Target.Column)) = "X"

es besteht eine einzel selection eine zelle bei 1

Target.Cells.Count = 1

die abfrage der 2 folgenden zeilen erwartet in spalte a ein SN oder GW

If UCase(Sh.Cells(Target.Row, 1)) = "SN" Then ZielTabelle = "Behandlungen"
If UCase(Sh.Cells(Target.Row, 1)) = "GW" Then ZielTabelle = "Behandlungen -GW"

b.s.
GW in spalte A und ein X in spalte 11 dann wird die aktive zeile kopiert,in diesem beispiel ja GW="Behandlungen -GW",also tabellenblett "Behandlungen -GW"

achja,verbundene zellen sind verboten

geschuetzte bereiche entsprechend aufheben,neu setzen

Answer 6

hi petra :-)

ein weiteres tabellenblatt,erfordert das einfuegen einer weiteren zeile

hier ein beispiel,wobei das kuerzel "NK" ist

If UCase(Sh.Cells(Target.Row, 1)) = "NK" Then ZielTabelle = "NeuerTabellenNamen"

gruss nighty

Answer 7

hi petra .-))

hab es noch bisl optimiert,es ist nun bei einfuegen von neuen tabellen keine aenderung mehr noetig.der worksheetname wird nun aus den letzten 2 zeichen abgeleitet

gruss nighty

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Column = 11 And UCase(Sh.Cells(Target.Row, Target.Column)) = "X" And Target.Cells.Count = 1 Then
Dim WksIndex As Integer
Application.EnableEvents = False
For WksIndex = 1 To Worksheets.Count
If UCase(Right(Worksheets(WksIndex).Name, 2)) = UCase(Sh.Cells(Target.Row, 1)) Then
If SheetExists("" & Worksheets(WksIndex).Name) = True Then
Sh.Rows(Target.Row).Copy
Worksheets(Worksheets(WksIndex).Name).Range("A" & Worksheets(Worksheets(WksIndex).Index).Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
Sh.Rows(Target.Row).Delete Shift:=xlUp
Exit For
End If
End If
If WksIndex = Worksheets.Count Then MsgBox "Tabelle *" & UCase(Sh.Cells(Target.Row, 1)) & "* gibt es nicht,Vorgang wird abgebrochen"
Next WksIndex
Application.CutCopyMode = False
Application.EnableEvents = True
End If
End Sub

Public Function SheetExists(strName As String) As Boolean
On Error Resume Next
SheetExists = Not Worksheets(strName) Is Nothing
End Function

Answer 8

hi nighty,

;-) erst mal vielen Dank für Deine Erläuterungen (Antwort 5), und Deine Hilfsbereitschaft.

Ganz ehrlich ? So langsam hab ich "Kringel" auf den Augen ....

Was ich einfach nicht hinbekomme ist die Tatsache, dass je 3 Werte der Blätter in feste Zellen übernommen werden müssen, bisher sah es so aus:

ThisWorkbook.Worksheets("Behandlungen").Range("A" & zeile) = .Range("I3")
ThisWorkbook.Worksheets("Behandlungen").Range("B" & zeile) = .Range("I4")
ThisWorkbook.Worksheets("Behandlungen").Range("C" & zeile) = .Range("I5")

Also I3 muss in A; I4 muss in B; I5 muss in C, dann des Rest der Zeile.
Ich habe - ohne Erfolg - versucht den alten Code anzupassen ;-(

Zum anderen kommt es zum
Laufzeitfehler 1004:
Die Delete-Methode des Range-Objekte konnte nicht ausgeführt werden.
Bezieht sich auf: Sh.Rows(Target.Row).Delete Shift:=xlUp

Dann bricht das Makro ab, ein Neustart ist nur möglich wenn ich alle Blätter schütze, und den Schutz dann wieder komplett aufhebe..

Würde es Sinn machen, wenn ich nochmals eine Testtabelle hochlade ????

Vielen Dank nochmals, und viele Grüße

Petra

Answer 9

hi petra :-)

du hast eine pn (persönliche nachricht)

gruss nighty