Kopieren von Zellen bei Bedingung

Zellen · 2021-02-17T16:24:38+00:00

Hallo zusammen, ich suche jetzt bereits seit einiger Zeit, finde aber kein VBA-Skript, welches sich an meine Bedürfnisse anpassen lässt. Folgende Problemstellung habe ich: Sobald in Tabellenblatt 1 in Spalte B der Wert "X" auftaucht, sollen in der dazugehörigen Zeile die Zellen A, D, G, H und F der Zelle in das Tabellenblatt 2 kopiert ab Zeile 5 kopiert werden. Es können in Tabellenblatt 1 in der Spalte B mehrere Zeilen mit X vorkommen und die Tabellenblätter werden stetig erweitert. In Tabellenblatt 2 sollen die Informationen immer in die nächste freie Zeile kopiert werden. Ich hoffe ich konnte mein Problem gut darstellen. Vielen Dank im voraus!!

Hallo,
das würde ich alles nur über das Doppelklick-Event regeln.
Doppelklick - X wird gesetzt - Datensatz wird in Tabelle3 kopiert - Tabelle3 wird sortiert
Doppelklick bei bereits gesetztem X - X wird entfernt - Datensatz wird in Tabelle3 entfernt - Tabelle3 wird sortiert.
So dürftest du dann auch nie doppelte in Tabelle3 haben.
Das funktioniert aber nur so, so lange du in Tabelle1 keine doppelt vorkommenden Namen hast.
Also mal dein Change Makro löschen und testen.

Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim raFund As Range
If Target.Column = 3 And Target.Row > 6 Then
Application.ScreenUpdating = False
Cancel = True
Target = IIf(Target = "", "X", "")
If Target = "X" Then
Union(Target.Offset(, -1), Target.Offset(, 1).Resize(1, 5)).Copy
With Tabelle3
.Cells(.Cells(.Rows.Count, "B").End(xlUp).Offset(1).Row, "B").PasteSpecial _
Paste:=xlPasteValuesAndNumberFormats
.Range("B6:G" & .Rows.Count).Sort Key1:=.Range("B6"), Order1:=xlAscending, _
Header:=xlYes
Application.CutCopyMode = False
End With
Else
Set raFund = Tabelle3.Columns("B").Find(what:=Target.Offset(, -1), _
LookIn:=xlValues, lookat:=xlWhole)
If Not raFund Is Nothing Then
With Tabelle3
.Rows(raFund.Row).ClearContents
.Range("B6:G" & .Rows.Count).Sort Key1:=.Range("B6"), Order1:=xlAscending, _
Header:=xlYes
End With
End If
End If
End If
Set raFund = Nothing
End Sub

Gruß Werner

Hallo,
und die Tabelle hat jetzt bitte was mit der ursprünglich hochgeladenen Datei zu tun? Richtig nichts.
Ich verstehe nicht, dass nicht verstanden wird wozu eine Beispielmappe nötig ist.

Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim raFund As Range, loLetzte As Long
If Target.Column = 2 And Target.Row > 4 Then
Application.ScreenUpdating = False
Cancel = True
Target = IIf(Target = "", "X", "")
If Target = "X" Then
With Worksheets("Prospects")
loLetzte = .Columns("A").Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, _
searchdirection:=xlPrevious).Offset(1).Row
Union(Target.Offset(, -1), Target.Offset(, 4).Resize(1, 3)).Copy
.Cells(loLetzte, "A").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Target.Offset(, 7).Copy
.Cells(loLetzte, "AI").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Range("A4:AJ" & loLetzte).Sort Key1:=.Range("A4"), Order1:=xlAscending, _
Header:=xlYes
Application.CutCopyMode = False
End With
Else
Set raFund = Worksheets("Prospects").Columns("A").Find(what:=Target.Offset(, -1), _
LookIn:=xlValues, lookat:=xlWhole)
If Not raFund Is Nothing Then
With Worksheets("Prospects")
loLetzte = .Columns("A").Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, _
searchdirection:=xlPrevious).Row
.Rows(raFund.Row).ClearContents
.Range("A4:AJ" & loLetzte).Sort Key1:=.Range("A4"), Order1:=xlAscending, _
Header:=xlYes
End With
End If
End If
End If
Set raFund = Nothing
End Sub

Gruß Werner

Kopieren von Zellen bei Bedingung

Forumthread: Kopieren von Zellen bei Bedingung

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Kopieren von Zellen bei Bedingung

Forumthread: Kopieren von Zellen bei Bedingung

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread