Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1872to1876
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Kopieren mit Bedingung

Kopieren mit Bedingung
07.03.2022 12:29:26
Ronny
Guten Tag zusammen,
ich habe eine Frage. Beispielmappe ist hier https://www.herber.de/bbs/user/151602.xlsx
Ich habe eine Tabelle in die Daten eingegeben werden.
Spalte A Name
Spalte B Datum
Spalte C Frist
Spalte D erhalten
ich würde jetzt gern einen Button erstellen bei dem, wenn in Spalte D ein x enthalten ist, soll die Zeile von A-D kopiert werden und zwar in das Tabellenblatt des Names aus Spalte A.
Anschließend soll die zuvor kopierte Zeile gelöscht werden in Tabellenblatt 1.
ich hoffe es ist einigermaßen verständlich.
Ich stehe da gerade absolut auf dem Schlauch wie ich das lösen könnte.
MfG
Ronny

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Kopieren mit Bedingung
07.03.2022 12:50:59
Rudi
Hallo,
in ein Modul:

Sub kopie()
Dim i As Long, w As String
Application.ScreenUpdating = False
With Sheets(1)
For i = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
w = .Cells(i, 1)
If .Cells(i, 4) = "x" Then
.Cells(i, 1).Resize(, 4).Copy _
Sheets(w).Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Cells(i, 1).Resize(, 4).Delete shift:=xlUp
End If
Next i
End With
End Sub
Gruß
Rudi
AW: Kopieren mit Bedingung
07.03.2022 13:00:17
UweD
Hallo
so?

Sub Übertragen()
Dim TB1 As Worksheet, TBx As Worksheet, SP As Integer, Spx As Integer, i As Integer
Dim LR1 As Integer, Z1 As Integer, Blatt As String
Set TB1 = Sheets("Sheet1")
SP = 1 'Spalte A
Z1 = 2 'erste Zeile mit Daten
Spx = 4 'Anzahl Spalten, die kopiert werden
With TB1
LR1 = .Cells(.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
For i = LR1 To Z1 Step -1
Blatt = .Cells(i, SP)
If Blatt  "" And .Cells(i, Spx) = "x" Then
'prüfen ob Blatt schon existiert
If IsError(Evaluate(Blatt & "!A1")) Then
Set TBx = Sheets.Add(after:=Sheets(Sheets.Count))
TBx.Name = Blatt
Else
Set TBx = Sheets(Blatt)
'reset
TBx.UsedRange.ClearContents
End If
With .Cells(i, SP).Resize(1, Spx)
.Copy TBx.Cells(1, SP)
.Delete xlUp
End With
End If
Next
.Activate
End With
End Sub
LG UweD
Anzeige
AW: Kopieren mit Bedingung
09.03.2022 08:21:06
Ronny
Hallo UweD,
Das klappt schon mal super.
Jedoch habe ich ein Problem und zwar wird die Zeile Frist automatisch mithilfe von B1+14 eingetragen und die bedingte Formatierung ab Fristablauf automatisch in rot. Dies verschwindet dann. könnte man das noch irgendwie einbauen oder ist das nicht möglich?
Falls nicht, würde ich das löschen dann auch weglassen
LG Ronny
AW: Kopieren mit Bedingung
09.03.2022 08:36:07
Ronny
Und noch eine Sachen, Er Soll wenn der Gleiche Name nochmals erscheint zu einem Späteren Zeitpunkt, die vorhandenen Daten nicht löschen sondern anfügen auf das Tabellenblatt des Namens.
TBx.UsedRange.ClearContents dies müsste ja denke ich dann raus aus der Formel wenn ich das richtig verstehe?
Anzeige
AW: Kopieren mit Bedingung
09.03.2022 08:56:23
UweD
Hallo
- Bedingte Formatierung wird bei mit mitkopiert und funktioniert auch im Zielblatt problemlos
- Zeilen werden nun unten angefügt

Sub Übertragen()
Dim TB1 As Worksheet, TBx As Worksheet, SP As Integer, Spx As Integer, i As Integer
Dim LR1 As Integer, LRx As Integer, Z1 As Integer, Blatt As String
Set TB1 = Sheets("Sheet1")
SP = 1 'Spalte A
Z1 = 2 'erste Zeile mit Daten
Spx = 4 'Anzahl spalten, die kopiert werden
With TB1
LR1 = .Cells(.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
For i = LR1 To Z1 Step -1
Blatt = .Cells(i, SP)
If Blatt  "" And .Cells(i, Spx) = "x" Then
'prüfen ob Blatt schon existiert/vorhanden
If IsError(Evaluate(Blatt & "!A1")) Then
Set TBx = Sheets.Add(after:=Sheets(Sheets.Count))
TBx.Name = Blatt
.Rows(1).Copy TBx.Rows(1)
Else
Set TBx = Sheets(Blatt)
End If
LRx = TBx.Cells(TBx.Rows.Count, SP).End(xlUp).Row
With .Cells(i, SP).Resize(1, Spx)
.Copy TBx.Cells(LRx + 1, SP)
.Delete xlUp
End With
End If
Next
.Activate
End With
End Sub
LG UweD
Anzeige
AW: Kopieren mit Bedingung
09.03.2022 10:35:20
Ronny
ja das klappt schon mal gut. Was müsste ich ändern um die Bedingte Formatierung nicht mitzukopieren?
AW: Kopieren mit Bedingung
09.03.2022 10:52:05
UweD
Hi
dann so...

Sub Übertragen()
Dim TB1 As Worksheet, TBx As Worksheet, SP As Integer, Spx As Integer, i As Integer
Dim LR1 As Integer, LRx As Integer, Z1 As Integer, Blatt As String
Set TB1 = Sheets("Sheet1")
SP = 1 'Spalte A
Z1 = 2 'erste Zeile mit Daten
Spx = 4 'Anzahl spalten, die kopiert werden
With TB1
LR1 = .Cells(.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
For i = LR1 To Z1 Step -1
Blatt = .Cells(i, SP)
If Blatt  "" And .Cells(i, Spx) = "x" Then
'prüfen ob Blatt schon existiert/vorhanden
If IsError(Evaluate(Blatt & "!A1")) Then
Set TBx = Sheets.Add(after:=Sheets(Sheets.Count))
TBx.Name = Blatt
.Rows(1).Copy TBx.Rows(1)
Else
Set TBx = Sheets(Blatt)
End If
LRx = TBx.Cells(TBx.Rows.Count, SP).End(xlUp).Row
With .Cells(i, SP).Resize(1, Spx)
TBx.Cells(LRx + 1, SP).Resize(1, Spx).Value = .Value
.Delete xlUp
End With
End If
Next
.Activate
End With
End Sub
LG UweD
Anzeige
AW: Kopieren mit Bedingung
11.03.2022 17:05:34
Ronny
Hallo Uwe sry das ich nochmal frage.
Ich habe deinen Code ein Wenig auf meine Bedürfnisse schon angepasst. Auch wenn ich diesen hier am wenigstens verstehe.

Sub Übertragen()
Dim TB1 As Worksheet, TBx As Worksheet, SP As Integer, Spx As Integer, i As Integer
Dim LR1 As Integer, LRx As Integer, Z1 As Integer, Blatt As String
Set TB1 = Sheets("Frist_Übersicht")
SP = 1 'Spalte A
Z1 = 2 'erste Zeile mit Daten
Spx = 4 'Anzahl spalten, die kopiert werden
With TB1
LR1 = .Cells(.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
For i = LR1 To Z1 Step -1
Blatt = .Cells(i, SP)
If Blatt  "" And .Cells(i, Spx) = "x" Then
'prüfen ob Blatt schon existiert/vorhanden
If IsError(Evaluate(Blatt & "!A1")) Then
Set TBx = Sheets.Add(after:=Sheets(Sheets.Count))
TBx.Name = Blatt
.Rows(1).Copy TBx.Rows(1)
Else
Set TBx = Sheets(Blatt)
End If
LRx = TBx.Cells(TBx.Rows.Count, SP).End(xlUp).Row
With .Cells(i, SP).Resize(1, Spx)
TBx.Cells(LRx + 1, SP).Resize(1, Spx).Value = .Value
.ClearContents
End With
End If
Next
.Activate
End With
Worksheets("Frist_Übersicht").Range("C2:C42").Value = "=B2+14"
End Sub
Jetzt habe ich noch ein Problem und zwar soll das Kopierte zwar die Bedingten Formatierungen nicht mitnehmen aber die Rahmen der Zellen schon. Also die normale Formatierung soll vorhanden bleiben.
Ich hatte es auch schon mit einer zweiten sub versucht welche dann die Bedingten Formatierungen in allen Blättern außer dem Ersten löscht, aber auch hier hatte ich Probleme. er hat immer nur auf dem ersten Blatt gelöscht und nicht auf den anderen.
Ich hoffe du kannst mir nochmal helfen
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige