Скрытый текст |
---|
Sub ZakPok() Dim ChPoZak As Object Dim aa(), ix(), avl(), ak(), zak(), pr(), ii&, lstr%, i%, min(), sel& Range("B4").ListObject.QueryTable.Refresh BackgroundQuery:=False Application.Wait Time:=Now + TimeSerial(0, 0, 2) lstr = Cells(Rows.Count, 4).End(xlUp).Row [E8].AutoFill Destination:=Range("E8:E" & lstr) aa = Range("E8:E" & lstr).Value Range("F8:J300").Clear Application.ScreenUpdating = False Set ChPoZak = GetObject("F:\Логистика\Что пора заказать.xlsm") avl = ChPoZak.Sheets(6).[A2].CurrentRegion.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(avl) .Item(avl(i, 1)) = i Next ReDim c(1 To UBound(aa), 1 To 1) ' For i = 1 To UBound(aa) If .exists(aa(i, 1)) Then ii = .Item(aa(i, 1)) c(i, 1) = avl(ii, 3) End If Next End With [H8].Resize(i - 1) = c() ix = ChPoZak.Sheets(5).[A3].CurrentRegion.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(ix) .Item(ix(i, 1)) = i Next ReDim c(1 To UBound(aa), 1 To 1) ' For i = 1 To UBound(aa) If .exists(aa(i, 1)) Then ii = .Item(aa(i, 1)) c(i, 1) = ix(ii, 6) End If Next End With [G8].Resize(i - 1) = c() ak = ChPoZak.Sheets(7).UsedRange.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(ak) .Item(ak(i, 1)) = i Next ReDim c(1 To UBound(aa), 1 To 1) For i = 1 To UBound(aa) If .exists(aa(i, 1)) Then ii = .Item(aa(i, 1)) c(i, 1) = ak(ii, 15) End If Next End With [I8].Resize(i - 1) = c() min = ChPoZak.Sheets(4).[B2].CurrentRegion.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(min) .Item(min(i, 8) = i Next ReDim c(1 To UBound(aa), 1 To 2) For i = 1 To UBound(aa) If .exists(aa(i, 1)) Then ii = .Item(aa(i, 1)) c(i, 1) = min(ii, 5) If c(i, 2) = 0 Then min(ii, 6) = "" Else c(i, 2) = min(ii, 6) End If End If Next End With [J8:K8].Resize(i - 1) = c() Columns(12).ClearContents zak = ChPoZak.Sheets(2).UsedRange.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(zak) ' последняя строка исх.таблицы .Item(zak(i, 1)) = i ' заносим в словарь код Next ReDim c(1 To UBound(aa), 1 To 1) ' создаём размер итоговой таблицы For i = 1 To UBound(aa) If .exists(aa(i, 1)) Then ii = .Item(aa(i, 1)) If Application.Sum(Cells(i + 7, 10), Cells(i + 7, 11)) < Val(Cells(i + 7, 4)) Then c(i, 1) = zak(ii, 6) End If End If Next End With [L8].Resize(i - 1) = c() pr = ChPoZak.Sheets(8).UsedRange.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(pr) .Item(CStr(pr(i, 1))) = i Next ReDim c(1 To UBound(aa), 1 To 1) For i = 1 To UBound(aa) If .exists(aa(i, 1)) Then ii = .Item(aa(i, 1)) c(i, 1) = pr(ii, 15) End If Next End With [F8].Resize(i - 1) = c() Range("F5:K5").Copy Range("F8:K" & lstr).PasteSpecial Paste:=xlPasteFormats Range("J8:K" & lstr).HorizontalAlignment = xlRight sel = 7 + Selection.Rows.Count Range(Cells(sel + 1, 5), Cells(sel + 100, 12)).Clear ChPoZak.Saved = True Application.CutCopyMode = False Application.ScreenUpdating = True End Sub |
"..Сладку ягоду рвали вместе, горьку ягоду я одна."