2 Kriterien prüfen vor kopieren

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

Beliebteste Forumthreads (12 Monate)

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread