Dim wSh1 As Worksheet: Set wSh1 = [KOD1].Parent
Dim wSh2 As Worksheet: Set wSh2 = [KOD2].Parent
Dim wSh As Worksheet: Set wSh = [KOD].Parent '
Dim Arr(), lRow&
Dim rKOD As Range, rNAZV As Range, rCENA As Range, rEDIN As Range

With CreateObject("Scripting.Dictionary")

lRow = wSh1.Cells(wSh1.Rows.Count, [KOD1].Column).End(xlUp).Row - [KOD1].Row - 1
Set rNAZV = [NAZV1].Offset(2, 0).Resize(lRow)
Set rKOD = [KOD1].Offset(2, 0).Resize(lRow)
Set rCENA = [CENA1].Offset(2, 0).Resize(lRow)
Set rEDIN = [EDIN1].Offset(2, 0).Resize(lRow)
For lRow = 1 To rKOD.Rows.Count
.Item(Trim(rKOD(lRow))) = Array(rKOD(lRow).Value, rNAZV(lRow).Value, rCENA(lRow).Value, rEDIN(lRow).Value)
Next lRow

lRow = wSh2.Cells(wSh2.Rows.Count, [KOD2].Column).End(xlUp).Row - [KOD2].Row - 1
Set rNAZV = [NAZV2].Offset(2, 0).Resize(lRow)
Set rKOD = [KOD2].Offset(2, 0).Resize(lRow)
Set rCENA = [CENA2].Offset(2, 0).Resize(lRow)
Set rEDIN = [EDIN2].Offset(2, 0).Resize(lRow)
For lRow = 1 To rKOD.Rows.Count
.Item(Trim(rKOD(lRow))) = Array(rKOD(lRow).Value, rNAZV(lRow).Value, rCENA(lRow).Value, rEDIN(lRow).Value)
Next lRow
Arr = Application.Transpose(Application.Transpose(.Items))
End With
[KOD].Offset(2, 0).Resize(wSh.Cells.SpecialCells(xlCellTypeLastCell).Row, 4).ClearContents
[KOD].Offset(2, 0).Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
End Sub

Добрый день.
Данный макрос подтягивает уникальные из 2 листов, но если один из листов пустой, то макрос выдает ошибку. Подскажите что нужно изменить, что бы в случае если один лист пустой он подтягивал уникальные только с одного листа.