Autom Übernahme von Daten in anderes Tabellenblatt

Computer: Software & Programmierung Visual Basic
#1

Hallo Experten,

Ich brauche Eure Hilfe. Ich komme einfach nicht dahinter wie es geht.
Ich habe 2 Tabellenblätter. im Blatt „Quelle“ werden die Daten eingetragen, welche im Blatt „Ziel“ übernommen werden sollten.
Mein Problem liegt darin dass ich im Blatt „Ziel“ die Bemerkungen nur übernehmen will, wenn diese in der „Quelle“ auch eingetragen sind. Ansonsten sollen die Bemerkungen wegbleiben.

Also im Beispiel auf dem Blatt „Ziel“ sollte die Zelle A38 leer bleiben, da oberhalb auch kein Name erscheint.

Hier ist die Mappe:
http://www.file-upload.net/download-7328508/TestMapp…

Und hier der Code:

Sub Test()
Call loeschen
 Dim ze&, sp%
 For ze = 6 To 38
 For sp = 1 To 9



'Namen einfügen
 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 6 Then \_
 Sheets("Ziel").Cells(ze, 1) = Sheets("Quelle").Cells(ze, 1)

 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 42 Then \_
 Sheets("Ziel").Cells(ze, 1) = Sheets("Quelle").Cells(ze, 1)

 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 45 Then \_
 Sheets("Ziel").Cells(ze, 1) = Sheets("Quelle").Cells(ze, 1)

 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 22 Then \_
 Sheets("Ziel").Cells(ze, 1) = Sheets("Quelle").Cells(ze, 1)

 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 28 Then \_
 Sheets("Ziel").Cells(ze, 1) = Sheets("Quelle").Cells(ze, 1)


'X hinzu
 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 6 Then \_
 Sheets("Ziel").Cells(ze, sp) = Sheets("Quelle").Cells(ze, sp)

 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 42 Then \_
 Sheets("Ziel").Cells(ze, sp) = Sheets("Quelle").Cells(ze, sp)

 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 45 Then \_
 Sheets("Ziel").Cells(ze, sp) = Sheets("Quelle").Cells(ze, sp)

 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 22 Then \_
 Sheets("Ziel").Cells(ze, sp) = Sheets("Quelle").Cells(ze, sp)

 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 48 Then \_
 Sheets("Ziel").Cells(ze, sp) = Sheets("Quelle").Cells(ze, sp)


'Bemerkung hinzu
 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 43 Then \_
 Sheets("Ziel").Cells(ze, 1) = Sheets("Quelle").Cells(ze, 2)



' Alle farben übernehmen
 Sheets("Ziel").Cells(ze, sp).Interior.ColorIndex = Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex



 Next sp
 Next ze


End Sub


Sub loeschen()
Sheets("Ziel").Activate
Range("A6:I38").ClearContents
Range("A6:I38").Select
With Selection.Interior
 .Pattern = xlNone
 .TintAndShade = 0
 .PatternTintAndShade = 0
 End With
Range("A1").Select
End Sub

Kann mir jemand helfen?

#2

Ich habe 2 Tabellenblätter. im Blatt „Quelle“ werden die Daten
eingetragen, welche im Blatt „Ziel“ übernommen werden sollten.
Mein Problem liegt darin dass ich im Blatt „Ziel“ die
Bemerkungen nur übernehmen will, wenn diese in der „Quelle“
auch eingetragen sind. Ansonsten sollen die Bemerkungen
wegbleiben.

Also im Beispiel auf dem Blatt „Ziel“ sollte die Zelle A38
leer bleiben, da oberhalb auch kein Name erscheint.
http://www.file-upload.net/download-7328508/TestMapp…

Hallo Sascha,

nachstehend dein leicht frisierter Code.
Die Farben irritieren mich.

Warum prüfst du die Farben 6, 22, 42, 45 in der Forschleife „doppelt“
ab, ist doch mehr als seltsam?

Ingesamt hast du 11 IF-s, also 11 Farbprüfungen.
Rechne ich mal die vier doppelten ab bleiben noch 7 Farben.
6, 22, 42, 45, 28, 48, 43
Nun haben aber sowohl Quelle als auch Ziel jeweils nur vierFarben:
Quelle: 6, 43, 42, 4 6
 Ziel: 6, 43, 42, 4 5

22, 28, 48 gibts gar nicht, danach wird aber gesucht.
46 gibt es danach wird aber nicht gesucht.

Zu „doppelt“, das meine ich damit:

If Sheets(„Quelle“).Cells(ze, sp).Interior.ColorIndex = 6 Then _
Sheets(„Ziel“).Cells(ze, 1) = Sheets(„Quelle“).Cells(ze, 1)
If Sheets(„Quelle“).Cells(ze, sp).Interior.ColorIndex = 6 Then _
Sheets(„Ziel“).Cells(ze, sp) = Sheets(„Quelle“).Cells(ze, sp)

Wenn sp 1 ist so ist das doch doppelt gemacht.
Wenn sp 2 oder mehr ist , naja, muß ich noch durchdenken,
habe grad blackout, wohl zu lange mit den Farben beschäftigt
oder so :smile:

Ich warte ma ab was du antwortest dann schau ich nochmal um dir dein
Problem versuchen zu lösen.

Sorry, daß ich erst jetzt antworte.

Gruß
Reinhard

Option Explicit

Sub Test()
Call loeschen
Dim ze&, sp%
For ze = 6 To 38
 For sp = 1 To 9
 'Namen einfügen
 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 6 Then \_
 Sheets("Ziel").Cells(ze, 1) = Sheets("Quelle").Cells(ze, 1)
 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 42 Then \_
 Sheets("Ziel").Cells(ze, 1) = Sheets("Quelle").Cells(ze, 1)
 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 45 Then \_
 Sheets("Ziel").Cells(ze, 1) = Sheets("Quelle").Cells(ze, 1)
 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 22 Then \_
 Sheets("Ziel").Cells(ze, 1) = Sheets("Quelle").Cells(ze, 1)
 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 28 Then \_
 Sheets("Ziel").Cells(ze, 1) = Sheets("Quelle").Cells(ze, 1)
 'X hinzu
 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 6 Then \_
 Sheets("Ziel").Cells(ze, sp) = Sheets("Quelle").Cells(ze, sp)
 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 42 Then \_
 Sheets("Ziel").Cells(ze, sp) = Sheets("Quelle").Cells(ze, sp)
 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 45 Then \_
 Sheets("Ziel").Cells(ze, sp) = Sheets("Quelle").Cells(ze, sp)
 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 22 Then \_
 Sheets("Ziel").Cells(ze, sp) = Sheets("Quelle").Cells(ze, sp)
 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 48 Then \_
 Sheets("Ziel").Cells(ze, sp) = Sheets("Quelle").Cells(ze, sp)
 'Bemerkung hinzu
 If Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex = 43 Then \_
 Sheets("Ziel").Cells(ze, 1) = Sheets("Quelle").Cells(ze, 2)
 ' Alle farben übernehmen
 Sheets("Ziel").Cells(ze, sp).Interior.ColorIndex = \_
 Sheets("Quelle").Cells(ze, sp).Interior.ColorIndex
 Next sp
Next ze
End Sub

Sub loeschen()
With Sheets("Ziel").Range("A6:I38").Interior
 .Parent.ClearContents
 .Pattern = xlNone
 .TintAndShade = 0
 .PatternTintAndShade = 0
End With
End Sub
#3

Hallo Reinhard.

Vielen lieben Dank für Deine Antwort.

Ja das stimmt, ich habe bei all meinen Tests die Farbcodes vertauscht. :frowning:

Auf alle Fälle habe ich gemerkt, dass meine Testmappe so nicht funktionieren wird, resp. im Ansatz falsch überlegt wurde. Bin dabei alles ein wenig zu umstrukturieren, damit die Mappe auch macht was si soll.

In diesem Sinne brauche ich noch Zeit um nochmals genauer meine Fragen zu stellen.

Ich melde mich wieder im Forum wenn ich soweit bin und noch Fragen dazu habe.

Ich hoffe das ist ok so!?

Nochmals lieben Dank für Deine Mühe und Dein Interesse an Anfänger-Fragen.

Ich war schon so oft froh für Deine Hilfe, und werde diese bestimmt ein weiteres Mal in Anspruch nehmen dürfen, so hoffe ich.

Liebe Grüsse
Sascha