Zellenabfrage nach Zeichenreihenfolge und Weiter
20.02.2017 16:21:01
Michael
Hi Jan,
teste mal: https://www.herber.de/bbs/user/111607.xlsm
Das Makro ...
Option Explicit
Sub vglWerte()
Dim Strg, Such ' ohne Angabe = as Variant, als Arrays
Dim arr(1 To 3) ' 1: Folie A, 2: Folie B, 3: Ausgabespalte
Dim i&, j&, k&, k2&, t& ' & = as long
Dim s$ ' $ = as string
Dim o As Object
Dim t0 As Single
t0 = Timer
Strg = Range("Q4:U6") ' Tabellenbereich zur Steuerung des Makros
For i = 1 To 3
With Sheets(Strg(i, 1))
If i = 3 Then
Strg(i, 5) = Strg(1, 5)
Else
Strg(i, 5) = .Range(Strg(i, 2) & .Rows.Count).End(xlUp).Row
End If
arr(i) = .Range(Strg(i, 2) & Strg(i, 3)). _
Resize(Strg(i, 5) - Strg(i, 3) + 1, Strg(i, 4)).Value
End With
Next
Set o = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr(2))
s = arr(2)(i, 2) & "|" & arr(2)(i, 3)
o(s) = o(s) & "|" & i
' die Zeile, die gerade bearbeitet wird, d.h.
' - in der das weitere Suchkriterium und
' - das Ergebnis stehen
Next
k = i - 1
k2 = o.Count
'Stop
For i = 1 To UBound(arr(1))
arr(3)(i, 1) = ""
s = arr(1)(i, 2) & "|" & arr(1)(i, 3)
If o.exists(s) Then
Such = Split(o(s), "|")
For j = 1 To UBound(Such)
t = InStr(1, arr(1)(i, 1), arr(2)(Such(j), 1), vbTextCompare)
If t > 0 Then
arr(3)(i, 1) = arr(2)(Such(j), 4) & " " & arr(2)(Such(j), 5)
Exit For
End If
Next
End If
Next
Sheets(Strg(3, 1)).Range(Strg(3, 2) & Strg(3, 3)).Resize(UBound(arr(3))) = arr(3)
Set o = Nothing
MsgBox "Erledigt in " & (Timer - t0) * 1000 & " ms." & vbLf & _
"übrigens sind in Folie B " & k & " Werte vorhanden," & vbLf & _
"im Dictionary sind es " & k2
End Sub
... verwendet Eingaben aus dem Tabellenbereich zur Steuerung: Strg = Range("Q4:U6")
Damit ist das Ding sehr variabel, d.h. Du kannst hier u.a. Blattnamen hinterlegen, in denen die einzelnen "Folien" stehen.
Schöne Grüße,
Michael
