Prüfen Ersetzen

Guten Tag,
vielen Dank nochmal für die Hilfe bei meinen vorherigen Beiträgen. Konnte mit den Tipps gut weiterarbeiten. Ein Problem habe ich noch, ich hoffe das ist nicht zu komplex.
Ich habe eine Tabelle:
https://www.herber.de/bbs/user/70343.xls
hier gibt es 3 Tabellenblätter,
Input Blatt was einen Ausschnitt von Daten zeigt, einmal ein
Paket Blatt und ein
Ergebnis Blatt.
Ich benötige eine Möglichkeit die es mir erlaubt im Ergebnis Blatt die Zeilen wieder auszugeben aber mit folgenden Kriterien:
1. Wenn die kompeltte Code Folge aus einer Zeile aus dem Tabellenblatt Paket in der Input Datei in einem Teil einer Zeile auftaucht, dann gib im Ausgabe Blatt die Zeile aus der Input Datei aus, lösche aber die Code die in der Paket Zeile vorkommen und ersetze Sie durch den neuen Code der hier angegeben ist. (Wenn diese Felder dann leer bleiben ist das OK) Die nicht betroffen Code müssen aber stehen bleiben.
2. Dabei ist aber noch zu beachten, das manche Pakete für alle Zeilen gelten und manche nur für bestimmte Baumuster.
(Jede Zeile aus dem Blatt Paket muss für das gesamte Dokument geprüft werden, die Reihenfolge kann eine andere sein)
Ich habe es über Formeln versucht, bin aber da an die Grenzen geraten. Vielleicht habt ihr ja eine Idee. Wäre super.
Ganz lieben Gruß
und danke schon mal im vorraus
Jens

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hi Jens,
was du mit
"2. Dabei ist aber noch zu beachten, das manche Pakete für alle Zeilen gelten und manche nur für bestimmte Baumuster."
schreibst, finde ich in der Beispielmappe nicht wieder. Wie sähen "Pakete für alle Zeilen" aus?
Was ich dort sehe, sind einige Pakete, die für bestimmte Baumuster, aber alle Gebiete gelten.
Das habe ich dann auch berücksichtigt in diesem Code:


Option Explicit
Sub PaketeEinpflegen()
Dim arrP, arrE, rngL As Range
Dim lngQz As Long, lngQs As Long, lngT As Long, lngP As Long
Dim zz As Long, pp As Long, cp As Long, cq As Long
With Sheets("Pakete")
arrP = .Cells(2, 1).Resize( _
.Cells(.Rows.Count, 1).End(xlUp).Row - 1, _
.Cells(1, .Columns.Count).End(xlToLeft).Column)
End With
With Sheets("Input")
lngQz = .Cells(.Rows.Count, 1).End(xlUp).Row
With .Rows(2).Resize(lngQz - 1)
Set rngL = .Find("*", .Cells(1, 1), xlValues, , _
xlByColumns, xlPrevious)
If rngL Is Nothing Then
lngQs = .Cells(1, 1).Column
Else
lngQs = rngL.Column
End If
End With
arrE = .Cells(1, 1).Resize(lngQz, lngQs).Value
For zz = 2 To lngQz
For pp = 1 To UBound(arrP)
If arrP(pp, 2) = arrE(zz, 3) And _
(arrP(pp, 3) = "alle" Or arrP(pp, 3) = arrE(zz, 5)) Then
For lngP = 1 To UBound(arrP, 2)
If IsEmpty(arrP(pp, lngP)) Then
lngP = lngP - 1
Exit For
End If
Next lngP
lngT = 0
For cp = 4 To lngP
For cq = 6 To lngQs
If arrP(pp, cp) = arrE(zz, cq) Then
lngT = lngT + 1
'Debug.Print lngT & " / " & arrP(pp, cp)
Exit For
End If
Next cq
Next cp
If lngT = lngP - 3 Then
lngT = 0
For cq = 1 To lngQs
For cp = 4 To lngP
If arrP(pp, cp) = arrE(zz, cq) Then
lngT = lngT + 1
'Debug.Print lngT & " x " & arrP(pp, cp)
arrE(zz, cq) = IIf(lngT = 1, arrP(pp, 1), "")
Exit For
End If
Next cp
Next cq
End If
End If
Next pp
Next zz
End With
With Sheets("Ausgabe")
.Cells(1, 1).Resize(UBound(arrE), UBound(arrE, 2)) = arrE
End With
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Option Explicit Sub PaketeEinpflegen2() Dim arrP, arrE, rngL As Range Dim lngQz As Long, lngQs As Long, lngT As Long, lngP As Long Dim zz As Long, pp As Long, cp As Long, cq As Long With Sheets("Pakete") arrP = .Cells(2, 1).Resize( _ .Cells(.Rows.Count, 1).End(xlUp).Row - 1, _ .Cells(1, .Columns.Count).End(xlToLeft).Column) End With With Sheets("Input") lngQz = .Cells(.Rows.Count, 1).End(xlUp).Row With .Rows(2).Resize(lngQz - 1) Set rngL = .Find("*", .Cells(1, 1), xlValues, , _ xlByColumns, xlPrevious) If rngL Is Nothing Then lngQs = .Cells(1, 1).Column Else lngQs = rngL.Column End If End With arrE = .Cells(1, 1).Resize(lngQz, lngQs).Value End With For zz = 2 To lngQz For pp = 1 To UBound(arrP) If arrP(pp, 2) = arrE(zz, 3) And _ (arrP(pp, 3) = "alle" Or arrP(pp, 3) = arrE(zz, 5)) Then For lngP = UBound(arrP, 2) To 0 Step -1 If Not IsEmpty(arrP(pp, lngP)) Then Exit For Next lngP lngT = 0 For cp = 4 To lngP For cq = 6 To lngQs If arrP(pp, cp) = arrE(zz, cq) Then lngT = lngT + 1 'Debug.Print lngT & " / " & arrP(pp, cp) Exit For End If Next cq If lngT

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