Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Заполнение диапазона значениями - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир 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(18Kb)
 
Ответить
СообщениеПриветствую всех!

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

Автор - Mayseven
Дата добавления - 13.09.2016 в 23:01
SLAVICK Дата: Среда, 14.09.2016, 00:26 | Сообщение № 2
Группа: Модераторы
Ранг: Старожил
Сообщений: 1834
Репутация: 613 ±
Замечаний: 0% ±

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

а ничего что dic.Items - одномерный массив - а Вы пытаетесь его впихнуть в двухмерный :o .
На сколько понял - Для Вашего примера можно так:
[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]
К сообщению приложен файл: __2.xlsm(26Kb)


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
с выгрузкой элементов словаря из листа "источник" в указанный диапазон на листе

а ничего что dic.Items - одномерный массив - а Вы пытаетесь его впихнуть в двухмерный :o .
На сколько понял - Для Вашего примера можно так:
[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]

Автор - SLAVICK
Дата добавления - 14.09.2016 в 00:26
Mayseven Дата: Среда, 14.09.2016, 13:53 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Очень выручили, спасибо!)
 
Ответить
СообщениеОчень выручили, спасибо!)

Автор - Mayseven
Дата добавления - 14.09.2016 в 13:53
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Заполнение диапазона значениями (Макросы/Sub)
Страница 1 из 11
Поиск:

Яндекс цитирования
© 2010-2016 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!