Liste vervollständigen-Kriterium prüfen und Zeile

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Tino, und alle anderen
erstmal natürlich vielen lieben Dank.
Boar das wird aber was dachte kann das auf meinen konkreten Fall ändern, wobei mir da wohl doch einiges an VBA-Wissen fehlt.
Deshalb ist es wohl besser gleich an der Originalliste zu bleiben.
Aus meinem Beispiel entsprechen:
- Spalte A (im Beispiel Material) heißt im Original Merkmalsname - entspricht aber ebenso Spalte A
- Spalte B (in meinem Beispiel Merkmal) entspricht in der Originalliste Spalte C (Überschrift = ZAEHLER)
- und Spalte C (in meinem Beispiel Sprache) entspricht in der Originalliste Spalte D (Überschrift = SPRAS)
Die zu prüfenden Sprachen stehen auf Tabellenblatt Sprachen
Ob die Ausgabe letztlich auf einem neuen Tabellenblatt oder rechts neben der Liste erfolgt ist im Prinzip egal. Besser wäre aber auf einem neuen Tabellenblatt.
Hier mal ein Teil der Originalliste:
https://www.herber.de/bbs/user/100362.xlsx
Ist also in Wirklichkeit nicht viel anders, ein paar Spalten mehr gibts noch.
Nur alleine bekomm ich das wohl nicht angepaßt, leider.
Getestet hab ich, nur wenn ich die rechte 'Ergebnisliste' entferne macht der gar nix mehr, und ich weiss nicht wirklich wieso.
Wärs möglich dass da nochmal drüberschaust, wäre echt super nett.
Danke, aber erstmal Mittagspause... Gruß Bernd

Hallo,

Sub aaaa()
Dim arrTMP, arrSPRAS, i As Long, j As Long
Dim objMZ As Object, objMZS As Object, vKey
Dim arrOut()
Set objMZ = CreateObject("Scripting.Dictionary")
Set objMZS = CreateObject("Scripting.Dictionary")
arrTMP = Sheets("Sheet1").Cells(1, 1).CurrentRegion
arrSPRAS = Sheets("Sprachen").Cells(1, 1).CurrentRegion
For i = 2 To UBound(arrTMP)
objMZ(arrTMP(i, 1) & "|" & arrTMP(i, 3)) = 0
objMZS(arrTMP(i, 1) & "|" & arrTMP(i, 3) & "|" & arrTMP(i, 4)) = arrTMP(i, 6)
Next
For Each vKey In objMZ
For i = 1 To UBound(arrSPRAS)
If Not objMZS.exists(vKey & "|" & arrSPRAS(i, 1)) Then
objMZS(vKey & "|" & arrSPRAS(i, 1)) = ""
End If
Next
Next
ReDim arrOut(1 To objMZS.Count + 1, 1 To 6)
arrOut(1, 1) = "Merkmal"
arrOut(1, 2) = "Bezeichnung"
arrOut(1, 3) = "Zähler"
arrOut(1, 4) = "SPRAS"
arrOut(1, 5) = "Sprache"
arrOut(1, 6) = "Wert"
j = 1
For Each vKey In objMZS
j = j + 1
arrOut(j, 1) = Split(vKey, "|")(0)
arrOut(j, 2) = Application.VLookup(arrOut(j, 1), Sheets("Sheet1").Range("A:B"), 2, 0)
arrOut(j, 3) = Split(vKey, "|")(1)
arrOut(j, 4) = Split(vKey, "|")(2)
arrOut(j, 5) = Application.VLookup(arrOut(j, 4), Sheets("Sprachen").Range("A:B"), 2, 0)
arrOut(j, 6) = objMZS(vKey)
Next
Sheets.Add.Cells(1, 1).Resize(UBound(arrOut), UBound(arrOut, 2)) = arrOut
End Sub

Gruß
Rudi

Beliebteste Forumthreads (12 Monate)

Liste vervollständigen-Kriterium prüfen und Zeile

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread