Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1680to1684
1680to1684
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

2 Kriterien prüfen vor kopieren

Forumthread: 2 Kriterien prüfen vor kopieren

2 Kriterien prüfen vor kopieren
10.03.2019 19:05:34
Tinchen
Hallo zusammen,
ich habe die 2 Subs (siehe File). Das Sub "kopieren" soll Spalte F in Sheet "Input" und "copy" prüfen. Wenn der Inhalt in beiden Sheets vorkommt, dann sollen die Spalten I-X im Copy Sheet durch den Inhalt dieser Spalten der gleichen Zeile aus Sheet "Input" aktualisiert werden. Falls der Wert in Spalte F nicht im "copy" Sheet vorkommt, dann soll die Zeile aus dem "input" sheet in das "copy" sheet kopiert werden.
https://www.herber.de/bbs/user/128279.xlsm
Meine Fragen:
- Es soll nicht nur Spalte F sondern Spalte F in Kombination mit Spalte K geprüft werden. 1. Nur wenn die Kombi in beiden Sheets übereinstimmt sollen die Spalten I-X aktualisiert werden. 2. Nur wenn die Kombi noch nicht im "copy" sheet ist soll diese Zeile in das "Copy" sheet kopiert werden.
- Das Sub "fresh" soll das gleiche machen wie das Sub "kopieren" nur umgedreht. Es soll prüfen ob im "input" sheet ein Wert auch im Copy Sheet vorkommt. Wenn dem so ist, die Spalten I-X aus dem Copy sheet in das "input" sheet kopieren.
Hoffe das ist irgendwie verständlich.
Vielen Dank,
Tinchen
Anzeige

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: 2 Kriterien prüfen vor kopieren
10.03.2019 22:21:03
AlterDresdner
Hallo Tinchen,
ich hoffe, ich habe richtig verstanden.
Was Du mit dem auskommentierten Code am Ende von kopierensub vorhattest, musst Du selber wissen. 
Public Sub kopieren()
kopierensub "Input", 6, "copy", 2
End Sub
Public Sub fresh()
kopierensub "Copy", 2, "Input", 6
End Sub
Sub kopierensub(Quellsheet As String, Quellstart As Long, _
Zielsheet As String, Zielstart As Long)
'Quellstart ist erste Datenzeile in Quellsheet, Zielstart analog
Dim letzteQ As Long, letzteZ As Long, zeile As Long
Dim wsQ As Worksheet, wsZ As Worksheet, found As Object
Dim firstadr As String, mustcopy As Boolean, mustupdate As Boolean
Set wsQ = Worksheets(Quellsheet): Set wsZ = Worksheets(Zielsheet)
Application.ScreenUpdating = False
With wsQ
letzteQ = .Cells(.Rows.Count, 6).End(xlUp).Row
letzteZ = wsZ.Cells(wsZ.Rows.Count, 6).End(xlUp).Row + 1
For zeile = Quellstart To letzteQ
mustcopy = False
mustupdate = False
Set found = wsZ.Range("F:F").Find(what:=.Cells(zeile, 6), _
after:=wsZ.Cells(1, 6), LookIn:=xlValues, lookat:=xlWhole)
If found Is Nothing Then 'noch nicht vorhanden
mustcopy = True
Else 'Bestellnr. in Copy schon da
firstadr = found.Address
If .Cells(zeile, 11) = wsZ.Cells(found.Row, 11) Then 'Kombi stimmt
mustupdate = True
Else 'Kombi stimmt nicht, weitersuchen, ob evtl.
Do
Set found = wsZ.Range("F:F").FindNext(found)
If .Cells(zeile, 11) = wsZ.Cells(found.Row, 11) Then _
mustupdate = True 'Kombi stimmt
Loop Until found.Address = firstadr Or mustupdate
If Not mustupdate Then mustcopy = True
End If
End If
If mustcopy Then 'ganze Zeile kopieren
.Rows(zeile).Copy Destination:=wsZ.Cells(letzteZ, 1)
letzteZ = letzteZ + 1
ElseIf mustupdate Then 'Spalte I-X kopieren
Application.DisplayAlerts = False
.Range(.Cells(zeile, 9), .Cells(zeile, 24)).Copy _
Destination:=wsZ.Cells(found.Row, 9) 'I-X kopieren
Application.DisplayAlerts = True
End If
Next zeile
Application.CutCopyMode = False
End With
With wsZ
letzteZ = .Cells(.Rows.Count, 6).End(xlUp).Row
'.Range(.Cells(1, 24), .Cells(letzteZ, 24)).FormulaLocal = "=ZEILE()"
'.Range(.Cells(1, 24), .Cells(letzteZ, 24)).Value = .Range(.Cells(2, 24), _
.Cells(letzteZ, 24)).Value
.Range("A" & Zielstart & ":Y" & letzteZ).Sort Key1:=.Range("X" & Zielstart), _
Order1:=xlDescending, Header:=xlNo
.Range("A" & Zielstart - 1 & ":Y" & letzteZ).RemoveDuplicates Columns:=6, Header:=xlYes
.Range("A" & Zielstart & ":Y" & letzteZ).Sort Key1:=.Range("Y" & Zielstart), _
Order1:=xlAscending, Header:=xlNo
'.Columns(24).ClearContents
End With
Application.ScreenUpdating = True
Set wsQ = Nothing: Set wsZ = Nothing
End Sub

Gruß der Martin
Anzeige
AW: 2 Kriterien prüfen vor kopieren
11.03.2019 16:50:24
Tinchen
Hallo Martin,
vielen Dank fuer diese super Hilfe. Mir sind beim testen 2 Sachen aufgefallen:
- Wenn der Wert im Sheet "Input" Spalte F ein zweites Mal vorkommt aber in Spalte K ein anderer steht (= Kombination ist noch nicht vorhanden im Copy Sheet) dann kopiert es nicht diese Spalte.
https://www.herber.de/bbs/user/128299.xlsm --- hier werden die letzten 3 Zeilen nicht kopiert.
- Wenn ich das Sub fresh ausloese, werden alle Zeilen in Input geloescht, welche nicht in Copy stehen. Dies soll nicht der Fall sein. Es sollen nur die Zeilen upgedatet werden, welche im Input und Copy Sheet vorhanden sind.
Vielen Dank schon Mal,
Tinchen
Anzeige
AW: 2 Kriterien prüfen vor kopieren
11.03.2019 18:54:07
AlterDresdner
Hallo Tinchen,
man soll eben alles lesen:
Das Problem liegt bei dem RemoveDuplicates (kurz vor Ende), dass muss heißen
.Range("A" & Zielstart - 1 & ":Y" & letzteZ).RemoveDuplicates Columns:=Array(6, 11), Header:=xlYes
Dann werden nur Duplikate nach Spalte F und K gelöscht, vorher war es nur Spalte F.
Gruß der Martin
Anzeige
AW: 2 Kriterien prüfen vor kopieren
11.03.2019 20:49:14
Tinchen
Hallo Martin,
danke dir für die schnelle Helfe.
Der Zweite Punkt funktioniert jetzt super!!! Mega. Danke!
Jedoch habe ich noch Probleme mit dem ersten Punkt. Wenn sich ein Wert in Spalte F wiederholt jedoch Spalte K unterschiedlich ist, wird nur eine Zeile mit dem Wert aus Spalte F übernommen. Jedoch soll die Zeile kopiert werden, wenn die Kombi aus Spalte F und K noch nicht vorhanden ist.
Danke! Grüße,
Tinchen
Anzeige
AW: 2 Kriterien prüfen vor kopieren
11.03.2019 21:29:08
Tinchen
Hi Martin,
ich glaub ich habs hinbekommen...:)
Danke nochal für die großartige Hilfe.
Schönen Abend noch,
Tinchen

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige