Заполнение диапазона значениями

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Заполнение диапазона значениями (Макросы/Sub)

Mayseven

Дата: Вторник, 13.09.2016, 23:01 | Сообщение № 1

Группа: Пользователи

Ранг: Новичок

Сообщений: 12

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Приветствую всех!

Надеюсь на Вашу помощь с выгрузкой элементов словаря из листа "источник" в указанный диапазон на листе "Лист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]
Файл прилагается ниже.

К сообщению приложен файл: __.rar (18.3 Kb)

Ответить

SLAVICK

Дата: Среда, 14.09.2016, 00:26 | Сообщение № 2

Группа: Модераторы

Ранг: Старожил

Сообщений: 2290

Репутация: 766 ±

Замечаний: 0% ±

2019

Цитата Mayseven, 13.09.2016 в 23:01, в сообщении № 1

с выгрузкой элементов словаря из листа "источник" в указанный диапазон на листе

а ничего что 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

[/vba]

Цитата Mayseven, 13.09.2016 в 23:01, в сообщении № 1

с выгрузкой элементов словаря из листа "источник" в указанный диапазон на листе

а ничего что dic.Items - одномерный массив - а Вы пытаетесь его впихнуть в двухмерный

.
На сколько понял - Для Вашего примера можно так:
[vba]

Код