Option Explicit
Private Const xKey = 1 'Столбец ключа
Private Const xValue = 5 'Столбец значения
Sub myVLOOKUP()
Dim file1 As String
file1 = ThisWorkbook.Path & "\Первый.xlsx"
Dim file2 As String
file2 = ThisWorkbook.Path & "\Второй.xlsx"
Dim Application_Calculation As XlCalculation
Application_Calculation = Application.Calculation
Application.Calculation = xlCalculationManual
Dim dic As Object
Set dic = GetDic(file1)
If Not dic Is Nothing Then
If dic.Count > 0 Then
FillFromDic file2, dic
End If
End If
Application.Calculation = Application_Calculation
End Sub
Private Sub FillFromDic(sFull As String, dic As Object)
Dim wb As Workbook
Set wb = GetWb(sFull, True)
If wb Is Nothing Then Exit Sub
FillSheet wb.Sheets(1), dic
End Sub
Private Sub FillSheet(sh As Worksheet, dic As Object)
Const nStep = 10000
Dim iStep As Long
Dim krr As Variant
Dim vrr As Variant
With sh
Dim yMax As Long
yMax = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim ys As Long
iStep = nStep
For ys = 1 To yMax Step nStep
If ys + nStep - 1 > yMax Then
iStep = yMax - ys + 1
End If
krr = GetArrayFromRange(.Cells(ys, 1).Resize(iStep))
ReDim vrr(1 To UBound(krr, 1), 1 To 1)
FillValueArray dic, krr, vrr
.Cells(ys, 2).Resize(UBound(vrr, 1)).Value = vrr
Next
End With
End Sub
Private Sub FillValueArray(dic As Object, krr As Variant, vrr As Variant)
Dim aKey As Variant
Dim yk As Long
For yk = 1 To UBound(krr, 1)
If krr(yk, 1) <> "" Then
aKey = GetKeyArray(CStr(krr(yk, 1)))
On Error Resume Next
vrr(yk, 1) = dic.Item(aKey(1)).Item(aKey(2)).Item(aKey(3)).Item(aKey(4)).Keys()(0)
On Error GoTo 0
End If
Next
End Sub
Private Function GetDic(sFull As String) As Object
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim wb As Workbook
Set wb = GetWb(sFull, True)
If Not wb Is Nothing Then
Dim sh As Worksheet
For Each sh In wb.Worksheets
FillDicFromSheet dic, sh
Next
If wb.ReadOnly Then wb.Close False
End If
Set GetDic = dic
End Function
Private Sub FillDicFromSheet(dic As Object, sh As Worksheet)
Dim tb As ListObject
For Each tb In sh.ListObjects
FillDicFromListObject dic, tb
Next
End Sub
Private Sub FillDicFromListObject(dic As Object, tb As ListObject)
Const nStep = 10000
Dim iStep As Long
Dim krr As Variant
Dim vrr As Variant
Dim yt As Long
iStep = nStep
For yt = 1 To tb.DataBodyRange.Rows.Count Step nStep
If yt + nStep - 1 > tb.DataBodyRange.Rows.Count Then
iStep = tb.DataBodyRange.Rows.Count - yt + 1
End If
krr = GetArrayFromRange(tb.DataBodyRange.Cells(yt, xKey).Resize(iStep))
vrr = GetArrayFromRange(tb.DataBodyRange.Cells(yt, xValue).Resize(iStep))
FillDicFromArrays dic, krr, vrr
Next
End Sub
Private Sub FillDicFromArrays(dic As Object, krr As Variant, vrr As Variant)
Dim yk As Long
For yk = 1 To UBound(krr, 1)
If krr(yk, 1) <> "" Then
AddDicItem dic, krr(yk, 1), vrr(yk, 1)
End If
Next
End Sub
Private Sub AddDicItem(dic As Object, ByVal sKey As String, vValue As Variant)
Dim aKey As Variant
aKey = GetKeyArray(sKey)
ReDim Preserve aKey(LBound(aKey) To UBound(aKey) + 1)
aKey(UBound(aKey)) = vValue
DicAdd dic, aKey
End Sub
Private Function GetKeyArray(sKey As String) As Variant
Dim longKey As String
longKey = GetKey(sKey)
Dim arr As Variant
ReDim arr(1 To 4)
Dim ya As Long
For ya = LBound(arr) To UBound(arr) - 1
arr(ya) = Mid(longKey, 1 + 4 * (ya - 1), 4)
Next
arr(ya) = Mid(longKey, 1 + 4 * (ya - 1), Len(longKey))
GetKeyArray = arr
End Function
Private Function GetKey(ByVal sKey As String) As String
Dim ss As String
If Len(sKey) < 16 Then
ss = sKey & String(15, "_")
ss = Left(ss, 16)
Else
ss = sKey
End If
GetKey = ss
End Function
Private Function GetWb(ByVal sFull As String, bReadOnly As Boolean) As Workbook
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(sFull) Then Exit Function
Dim sName As String
sName = fso.GetFileName(sFull)
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks(sName)
On Error GoTo 0
If Not wb Is Nothing Then
If LCase(wb.FullName) <> LCase(sFull) Then
wb.Close False
Set wb = Nothing
End If
End If
If wb Is Nothing Then
Set wb = Workbooks.Open(sFull, False, bReadOnly)
End If
Set GetWb = wb
End Function
Private Function GetArrayFromRange(rr As Range) As Variant
Dim arr As Variant
If rr.Cells.CountLarge = 1 Then
ReDim arr(1 To 1, 1 To 1)
arr(1, 1) = rr.Value
Else
arr = rr.Value
End If
ClearArray arr
GetArrayFromRange = arr
End Function
Private Sub ClearArray(arr As Variant)
Dim ya As Long
Dim xa As Long
For ya = LBound(arr, 1) To UBound(arr, 1)
For xa = LBound(arr, 2) To UBound(arr, 2)
If IsError(arr(ya, xa)) Then
arr(ya, xa) = Empty
End If
Next
Next
End Sub
Private Sub DicAdd(dic As Object, arr As Variant)
DicAddRecu dic, LBound(arr), arr
End Sub
Private Sub DicAddRecu(dic As Object, level As Long, arr As Variant)
If Not dic.Exists(arr(level)) Then
Set dic.Item(arr(level)) = CreateObject("Scripting.Dictionary")
End If
If level < UBound(arr) Then
Dim bic As Object
Set bic = dic.Item(arr(level))
DicAddRecu bic, level + 1, arr
Set dic.Item(arr(level)) = bic
End If
End Sub
|
