Надеюсь на Вашу помощь с выгрузкой элементов словаря из листа "источник" в указанный диапазон на листе "Лист2". Не выходит сделать так что бы значения соответствовали пересечениям названий статей и подразделений.
Писать для каждой строки Range("I10:M10") = dic .items Range("I11:M11") = dic .items не выйдет, всё равно вносит туда первую строку значений статьи1 и листа "источник"
[vba]
Код
Sub krivoy_code()
Dim A, B Dim dic Dim i As Integer, j As Integer
Set dic = CreateObject("Scripting.Dictionary")
A = Worksheets("источник").[a1].CurrentRegion.Value For i = 2 To UBound(A) For j = 2 To UBound(A, 2) dic(A(i, 1) & A(1, j)) = A(i, j) Next j Next i
With Worksheets(1) B = [a6].CurrentRegion.Value For i = 1 To UBound(B) For j = 1 To UBound(B, 2) If dic.Exists(B(i, 1) & B(j, 1)) Then Cells(i, 9) = dic(B(i, 1) & B(j, 1)) Next j Next i 'выгружает на весь диапазон только первую строку значений .Range("I9:M9") = dic.Items
'выгружает на весь диапазон только Статья1Подразделение5 '.Range("I9:M28") = dic.Items ()(i) End With
End Sub
[/vba] Файл прилагается ниже.
Приветствую всех!
Надеюсь на Вашу помощь с выгрузкой элементов словаря из листа "источник" в указанный диапазон на листе "Лист2". Не выходит сделать так что бы значения соответствовали пересечениям названий статей и подразделений.
Писать для каждой строки Range("I10:M10") = dic .items Range("I11:M11") = dic .items не выйдет, всё равно вносит туда первую строку значений статьи1 и листа "источник"
[vba]
Код
Sub krivoy_code()
Dim A, B Dim dic Dim i As Integer, j As Integer
Set dic = CreateObject("Scripting.Dictionary")
A = Worksheets("источник").[a1].CurrentRegion.Value For i = 2 To UBound(A) For j = 2 To UBound(A, 2) dic(A(i, 1) & A(1, j)) = A(i, j) Next j Next i
With Worksheets(1) B = [a6].CurrentRegion.Value For i = 1 To UBound(B) For j = 1 To UBound(B, 2) If dic.Exists(B(i, 1) & B(j, 1)) Then Cells(i, 9) = dic(B(i, 1) & B(j, 1)) Next j Next i 'выгружает на весь диапазон только первую строку значений .Range("I9:M9") = dic.Items
'выгружает на весь диапазон только Статья1Подразделение5 '.Range("I9:M28") = dic.Items ()(i) End With
с выгрузкой элементов словаря из листа "источник" в указанный диапазон на листе
а ничего что dic.Items - одномерный массив - а Вы пытаетесь его впихнуть в двухмерный . На сколько понял - Для Вашего примера можно так: [vba]
Код
Sub d() Dim A, B Dim dic Dim i As Integer, j As Integer
Set dic = CreateObject("Scripting.Dictionary") A = Worksheets("источник").[a1].CurrentRegion.Value For i = 2 To UBound(A) For j = 2 To UBound(A, 2) dic(A(i, 1) & A(1, j)) = A(i, j) Next j Next i
With Worksheets(1) B = [a6].CurrentRegion.Value n = (UBound(B, 2) - 3) / 2 ReDim c(1 To UBound(B) - 3, 1 To UBound(B, 2) - n - 3) For i = 4 To UBound(B) For j = n + 3 To UBound(B, 2) If dic.Exists(B(i, 1) & B(1, j)) Then c(i - 3, j - n - 3) = dic(B(i, 1) & B(1, j)) Next j Next i [a6].CurrentRegion.Cells(4, n + 4).Resize(UBound(c), UBound(c, 2)) = c End With End Sub
[/vba] Но лучше так [vba]
Код
Sub dd() Dim A, B Dim dicRows, dicRColumns, c, n# Dim i As Integer, j As Integer
Set dicRows = CreateObject("Scripting.Dictionary") Set dicRColumns = CreateObject("Scripting.Dictionary")
A = Worksheets("источник").[a1].CurrentRegion.Value For i = 2 To UBound(A) dicRows(A(i, 1)) = i Next i For j = 2 To UBound(A, 2) dicRColumns(A(1, j)) = j Next j
With Worksheets(1) B = [a6].CurrentRegion.Value n = (UBound(B, 2) - 3) / 2 ReDim c(1 To UBound(B) - 3, 1 To n) For i = 4 To UBound(B) For j = n + 4 To UBound(B, 2) If dicRows.Exists(B(i, 1)) And dicRColumns.Exists(B(1, j)) Then c(i - 3, j - n - 3) = A(dicRows(B(i, 1)), dicRColumns(B(1, j))) Next j Next i [a6].CurrentRegion.Cells(4, n + 4).Resize(UBound(c), UBound(c, 2)) = c End With End Sub
с выгрузкой элементов словаря из листа "источник" в указанный диапазон на листе
а ничего что dic.Items - одномерный массив - а Вы пытаетесь его впихнуть в двухмерный . На сколько понял - Для Вашего примера можно так: [vba]
Код
Sub d() Dim A, B Dim dic Dim i As Integer, j As Integer
Set dic = CreateObject("Scripting.Dictionary") A = Worksheets("источник").[a1].CurrentRegion.Value For i = 2 To UBound(A) For j = 2 To UBound(A, 2) dic(A(i, 1) & A(1, j)) = A(i, j) Next j Next i
With Worksheets(1) B = [a6].CurrentRegion.Value n = (UBound(B, 2) - 3) / 2 ReDim c(1 To UBound(B) - 3, 1 To UBound(B, 2) - n - 3) For i = 4 To UBound(B) For j = n + 3 To UBound(B, 2) If dic.Exists(B(i, 1) & B(1, j)) Then c(i - 3, j - n - 3) = dic(B(i, 1) & B(1, j)) Next j Next i [a6].CurrentRegion.Cells(4, n + 4).Resize(UBound(c), UBound(c, 2)) = c End With End Sub
[/vba] Но лучше так [vba]
Код
Sub dd() Dim A, B Dim dicRows, dicRColumns, c, n# Dim i As Integer, j As Integer
Set dicRows = CreateObject("Scripting.Dictionary") Set dicRColumns = CreateObject("Scripting.Dictionary")
A = Worksheets("источник").[a1].CurrentRegion.Value For i = 2 To UBound(A) dicRows(A(i, 1)) = i Next i For j = 2 To UBound(A, 2) dicRColumns(A(1, j)) = j Next j
With Worksheets(1) B = [a6].CurrentRegion.Value n = (UBound(B, 2) - 3) / 2 ReDim c(1 To UBound(B) - 3, 1 To n) For i = 4 To UBound(B) For j = n + 4 To UBound(B, 2) If dicRows.Exists(B(i, 1)) And dicRColumns.Exists(B(1, j)) Then c(i - 3, j - n - 3) = A(dicRows(B(i, 1)), dicRColumns(B(1, j))) Next j Next i [a6].CurrentRegion.Cells(4, n + 4).Resize(UBound(c), UBound(c, 2)) = c End With End Sub