Option Explicit
Sub Заполнить()
Dim r2 As Range
Set r2 = Sheets("Лист2").Range("D1").Resize(4501, 5001)
Dim dic As Object
Set dic = GetDic(Sheets("Sheet1"))
Dim arX As Variant
Dim arY As Variant
Dim arr As Variant
arX = r2.Rows(1)
arY = r2.Columns(1)
ReDim arr(2 To UBound(arY, 1), 2 To UBound(arX, 2))
Dim sKey As String
Dim y As Long
Dim x As Long
For y = 2 To UBound(arr, 1)
Application.StatusBar = Format(y / UBound(arr, 1), "0%")
For x = 2 To UBound(arr, 2)
If dic.Exists(arY(y, 1)) Then
If dic.Item(arY(y, 1)).Exists(arX(1, x)) Then
arr(y, x) = dic.Item(arY(y, 1)).Item(arX(1, x))
End If
End If
Next
Next
r2.Cells(2, 2).Resize(UBound(arr, 1) - LBound(arr, 1) + 1, UBound(arr, 2) - LBound(arr, 2) + 1) = arr
Application.StatusBar = False
End Sub
Function GetDic(sh As Worksheet) As Object
With sh
Dim y As Long
y = .Cells(.Rows.Count, "D").End(xlUp).Row
If y = 1 Then y = 2
Dim d As Variant
Dim i As Variant
Dim m As Variant
d = .Range(.Cells(1, "D"), .Cells(y, "D"))
i = .Range(.Cells(1, "I"), .Cells(y, "I"))
m = .Range(.Cells(1, "M"), .Cells(y, "M"))
End With
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
For y = 1 To UBound(d, 1)
If Not dic.Exists(i(y, 1)) Then Set dic.Item(i(y, 1)) = CreateObject("Scripting.Dictionary")
dic.Item(i(y, 1)).Item(m(y, 1)) = d(y, 1)
Next
Set GetDic = dic
End Function
|