Als Antwort auf diesen Beitrag
Hallo Christian;
Ich denke mal so.
Sub SchreibeAZN_A_bis_C()
Dim wsCodes As Worksheet, wsLeute As Worksheet, wsAZN As Worksheet
Dim lastRow As Long, i As Long
Dim arrCodes As Variant
Dim nameMatch As Variant
Dim codeVal As String, nameVal As Variant, dateVal As Variant
Dim valF As Double
Dim dictAZN As Object
Dim key As Variant
Dim arrOut() As Variant
Set wsCodes = ThisWorkbook.Worksheets("Codes")
Set wsLeute = ThisWorkbook.Worksheets("Leute")
Set wsAZN = ThisWorkbook.Worksheets("AZN")
Set dictAZN = CreateObject("Scripting.Dictionary")
'--- Codes D:F einlesen ---
lastRow = wsCodes.Cells(wsCodes.Rows.Count, "D").End(xlUp).Row
If lastRow < 1 Then Exit Sub
arrCodes = wsCodes.Range("D1:F" & lastRow).Value
'--- AZN-Daten sammeln ---
For i = 1 To UBound(arrCodes, 1)
codeVal = Trim(CStr(arrCodes(i, 1))) 'Spalte D
dateVal = arrCodes(i, 2) 'Spalte E
If IsNumeric(arrCodes(i, 3)) Then 'Spalte F
valF = CDbl(arrCodes(i, 3))
If valF <= 0.1 And valF > 0 And codeVal <> "" Then
If Not dictAZN.Exists(codeVal) Then
nameMatch = Application.VLookup(codeVal, wsLeute.Range("B:C"), 2, False)
If Not IsError(nameMatch) Then
nameVal = nameMatch
Else
nameVal = ""
End If
dictAZN.Add codeVal, Array(nameVal, dateVal)
End If
End If
End If
Next i
'--- Ausgabe in AZN!A:C ---
wsAZN.Range("A:C").ClearContents
If dictAZN.Count > 0 Then
ReDim arrOut(1 To dictAZN.Count, 1 To 3)
i = 1
For Each key In dictAZN.Keys
arrOut(i, 1) = key
arrOut(i, 2) = dictAZN(key)(0)
arrOut(i, 3) = dictAZN(key)(1)
i = i + 1
Next key
wsAZN.Range("A1").Resize(dictAZN.Count, 3).Value = arrOut
End If
End Sub