Kopieren von Zellen bei Bedingung

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub SpalteB() Dim TB1 As Worksheet, TB2 As Worksheet Dim ZNeu As Integer, Sp1 As Integer, SpSuch As Integer Dim LR1 As Long, Z As Long Dim Suchwort As String Set TB1 = Sheets("Tabelle1") Set TB2 = Sheets("Tabelle2") Sp1 = 1 'Spalte A SpSuch = 2 'Spalte B ZNeu = 5 ' ab Zeile 5 Suchwort = "X" With TB1 LR1 = .Cells(.Rows.Count, SpSuch).End(xlUp).Row 'letzte Zeile der Spalte For Z = 1 To LR1 If .Cells(Z, SpSuch) = Suchwort Then ZNeu = WorksheetFunction.Max(ZNeu, TB2.Cells(TB2.Rows.Count, Sp1).End(xlUp).Row _ + 1) TB2.Cells(ZNeu, 1).Value = .Cells(Z, 1).Value TB2.Cells(ZNeu, 2).Value = .Cells(Z, 4).Value TB2.Cells(ZNeu, 3).Value = .Cells(Z, 7).Value TB2.Cells(ZNeu, 4).Value = .Cells(Z, 8).Value TB2.Cells(ZNeu, 5).Value = .Cells(Z, 6).Value End If Next End With End Sub

Hallo,
erstmal vielen Dank für die schnelle Antwort!
@Werner: Nein - leider war mir das nicht klar, macht aber Sinn. Gibt es eine Möglichkeit, dass geprüft wird, ob die Einträge bereits vorhanden sind?
@UweD: Danke für das Skript, leider macht es genau das von Werner prophezeite und kopiert die Daten dann ggf. doppelt.
Ich habe mal eine Beispieldatei hochgeladen, die eigentlich genau das macht, was ich möchte. Leider kriege ich diese nicht auf meine Zellen angepasst. Dort kann ich durch ein "X" in Tabelle1 Spalte C die Daten in Tabelle2 übertragen. Lösche ich das X, werden dementsprechend auch die Daten in Tabelle2 gelöscht.
https://www.herber.de/bbs/user/144029.xls
Viele Grüße
Dominic

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

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

Beliebteste Forumthreads (12 Monate)

Kopieren von Zellen bei Bedingung

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

290 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Kopieren von Zellen bei Bedingung

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

290 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread