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

Вход

Регистрация

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

 

= Мир MS Excel/Изменение размерности многомерного массива - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Изменение размерности многомерного массива (Макросы/Sub)
Изменение размерности многомерного массива
Sashagor1982 Дата: Среда, 11.01.2023, 16:35 | Сообщение № 1
Группа: Проверенные
Ранг: Обитатель
Сообщений: 268
Репутация: -6 ±
Замечаний: 0% ±

Excel 2007
Добрый день. В приведенной функции формируется массив на вход которой поступает область листа, для заполнения ListBox

[vba]
Код
Function GetTableBodyRange(aColumns, a)
'Dim e(1 To UBound(a), 1 To UBound(aColumns) + 1)
'Dim a
Dim i, j, num
num = 1
ReDim e(1 To UBound(a), 1 To UBound(aColumns) + 1)

For i = 1 To UBound(a)
    If a(i, 7) = "" Then
    Else
    For j = LBound(aColumns) To UBound(aColumns)
        If (j = 4) Then
            e(num, j + 1) = Format(a(i, aColumns(j)), "dd.mm.yyyy")
        Else
            e(num, j + 1) = a(i, aColumns(j))
        End If
    Next
    num = num + 1
    End If
Next

'ReDim Preserve e(1 To num, 1 To UBound(aColumns) + 1)
GetTableBodyRange = e

End Function
[/vba]
Однако размер массива соответствует количеству строк области, необходимо сделать размер соответствующий количеству данных, в моем примере это num
[vba]
Код
ReDim Preserve e(1 To num, 1 To UBound(aColumns) + 1)
[/vba]
Такое решение выдает ошибку, прошу прощение за туфтологию
К сообщению приложен файл: 123.xlsx(33.2 Kb)
 
Ответить
СообщениеДобрый день. В приведенной функции формируется массив на вход которой поступает область листа, для заполнения ListBox

[vba]
Код
Function GetTableBodyRange(aColumns, a)
'Dim e(1 To UBound(a), 1 To UBound(aColumns) + 1)
'Dim a
Dim i, j, num
num = 1
ReDim e(1 To UBound(a), 1 To UBound(aColumns) + 1)

For i = 1 To UBound(a)
    If a(i, 7) = "" Then
    Else
    For j = LBound(aColumns) To UBound(aColumns)
        If (j = 4) Then
            e(num, j + 1) = Format(a(i, aColumns(j)), "dd.mm.yyyy")
        Else
            e(num, j + 1) = a(i, aColumns(j))
        End If
    Next
    num = num + 1
    End If
Next

'ReDim Preserve e(1 To num, 1 To UBound(aColumns) + 1)
GetTableBodyRange = e

End Function
[/vba]
Однако размер массива соответствует количеству строк области, необходимо сделать размер соответствующий количеству данных, в моем примере это num
[vba]
Код
ReDim Preserve e(1 To num, 1 To UBound(aColumns) + 1)
[/vba]
Такое решение выдает ошибку, прошу прощение за туфтологию

Автор - Sashagor1982
Дата добавления - 11.01.2023 в 16:35
_Boroda_ Дата: Среда, 11.01.2023, 16:41 | Сообщение № 2
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16550
Репутация: 6441 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
А справку читали по ReDim Preserve? Попробуйте, там русским по белому написано, что можно менять только последнюю размерность массива. А Вы меняете первую


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеА справку читали по ReDim Preserve? Попробуйте, там русским по белому написано, что можно менять только последнюю размерность массива. А Вы меняете первую

Автор - _Boroda_
Дата добавления - 11.01.2023 в 16:41
Sashagor1982 Дата: Среда, 11.01.2023, 20:17 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 268
Репутация: -6 ±
Замечаний: 0% ±

Excel 2007
_Boroda_, Комментариями отмечена попытка решения:
[vba]
Код
Dim e(1 To UBound(a), 1 To UBound(aColumns) + 1)
[/vba]
и
[vba]
Код
ReDim Preserve e(1 To num, 1 To UBound(aColumns) + 1)
[/vba]
в первой строке при этом возникает ошибка
 
Ответить
Сообщение_Boroda_, Комментариями отмечена попытка решения:
[vba]
Код
Dim e(1 To UBound(a), 1 To UBound(aColumns) + 1)
[/vba]
и
[vba]
Код
ReDim Preserve e(1 To num, 1 To UBound(aColumns) + 1)
[/vba]
в первой строке при этом возникает ошибка

Автор - Sashagor1982
Дата добавления - 11.01.2023 в 20:17
Gustav Дата: Среда, 11.01.2023, 22:00 | Сообщение № 4
Группа: Друзья
Ранг: Старожил
Сообщений: 2304
Репутация: 918 ±
Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1
можно менять только последнюю размерность массива

А если надо поменять первую, то, видимо, придётся сначала сформировать массив, повернутый на 90 градусов. С поставленными наоборот размерностями (т.е. ожидаемые на выходе строки при этом временно станут столбцами, а столбцы - строками). А после всех манипуляций массив разворачивается обратно с помощью функции WorksheetFunction.Transpose.

Sashagor1982, и, кстати, Вам же, вроде, больше года назад уже помогали в похожем вопросе:
Заполнение ListBox значениями из умной таблицы
Так там всё работает. Надо только Sub test поместить в модуль листа и проследить, чтобы на этом листе был список с именем ListBox1 (из тулбара "Элементы AxtiveX").


МОИ: Ник, Tip box: 41001663842605
 
Ответить
Сообщение
можно менять только последнюю размерность массива

А если надо поменять первую, то, видимо, придётся сначала сформировать массив, повернутый на 90 градусов. С поставленными наоборот размерностями (т.е. ожидаемые на выходе строки при этом временно станут столбцами, а столбцы - строками). А после всех манипуляций массив разворачивается обратно с помощью функции WorksheetFunction.Transpose.

Sashagor1982, и, кстати, Вам же, вроде, больше года назад уже помогали в похожем вопросе:
Заполнение ListBox значениями из умной таблицы
Так там всё работает. Надо только Sub test поместить в модуль листа и проследить, чтобы на этом листе был список с именем ListBox1 (из тулбара "Элементы AxtiveX").

Автор - Gustav
Дата добавления - 11.01.2023 в 22:00
Sashagor1982 Дата: Среда, 11.01.2023, 22:22 | Сообщение № 5
Группа: Проверенные
Ранг: Обитатель
Сообщений: 268
Репутация: -6 ±
Замечаний: 0% ±

Excel 2007
Gustav, Я использовал эту задачу, вопрос состоит в том как убрать пустые строки
 
Ответить
СообщениеGustav, Я использовал эту задачу, вопрос состоит в том как убрать пустые строки

Автор - Sashagor1982
Дата добавления - 11.01.2023 в 22:22
Gustav Дата: Среда, 11.01.2023, 23:00 | Сообщение № 6
Группа: Друзья
Ранг: Старожил
Сообщений: 2304
Репутация: 918 ±
Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1
Sashagor1982, с какими значениями параметров aColumns и a собираетесь вызывать свою (из этой темы) функцию GetTableBodyRange применительно к файлу из сообщения № 1?

[p.s.]под вечерний телевизор разродился - замастырил на основе функции R_Dmitry из старой темы:[/p.s.]
[vba]
Код
Function GetTableBodyRange(aColumns, a)
    Dim e(), i, j, num, cnt
    For i = 1 To UBound(a)
        'проверка строки на пустоту
        cnt = 0
        For j = LBound(aColumns) To UBound(aColumns)
            If VarType(a(i, aColumns(j))) = vbEmpty Then
                cnt = cnt + 1
            Else
                Exit For
            End If
        Next j
        'добавление непустой строки - столбцом в массив, развернутый на 90 градусов
        If cnt < UBound(aColumns) + 1 Then
            num = num + 1
            'увеличиваем вторую размерность развернутого массива
            'т.е. добавляем столбец, который в конце концов станет строкой
            ReDim Preserve e(1 To UBound(aColumns) + 1, 1 To num)
            For j = LBound(aColumns) To UBound(aColumns)
                If VarType(a(i, aColumns(j))) = vbDate Then
                    'преобразование дат в привычный формат
                    e(j + 1, num) = Format(a(i, aColumns(j)), "dd.mm.yyyy")
                Else
                    e(j + 1, num) = a(i, aColumns(j))
                End If
            Next j
        End If
    Next i
    'обратный разворот массива на 90 градусов - столбцы становятся строками
    GetTableBodyRange = WorksheetFunction.Transpose(e)
End Function
[/vba]

Тестовая процедура - в модуль листа, на котором ListBox1:
[vba]
Код
Sub test_()
    Dim a
    a = Sheets("List").ListObjects("tblOrder").DataBodyRange.Value
    Me.ListBox1.List = GetTableBodyRange(Array(1, 4, 2, 3), a)
End Sub
[/vba]


МОИ: Ник, Tip box: 41001663842605

Сообщение отредактировал Gustav - Четверг, 12.01.2023, 00:33
 
Ответить
СообщениеSashagor1982, с какими значениями параметров aColumns и a собираетесь вызывать свою (из этой темы) функцию GetTableBodyRange применительно к файлу из сообщения № 1?

[p.s.]под вечерний телевизор разродился - замастырил на основе функции R_Dmitry из старой темы:[/p.s.]
[vba]
Код
Function GetTableBodyRange(aColumns, a)
    Dim e(), i, j, num, cnt
    For i = 1 To UBound(a)
        'проверка строки на пустоту
        cnt = 0
        For j = LBound(aColumns) To UBound(aColumns)
            If VarType(a(i, aColumns(j))) = vbEmpty Then
                cnt = cnt + 1
            Else
                Exit For
            End If
        Next j
        'добавление непустой строки - столбцом в массив, развернутый на 90 градусов
        If cnt < UBound(aColumns) + 1 Then
            num = num + 1
            'увеличиваем вторую размерность развернутого массива
            'т.е. добавляем столбец, который в конце концов станет строкой
            ReDim Preserve e(1 To UBound(aColumns) + 1, 1 To num)
            For j = LBound(aColumns) To UBound(aColumns)
                If VarType(a(i, aColumns(j))) = vbDate Then
                    'преобразование дат в привычный формат
                    e(j + 1, num) = Format(a(i, aColumns(j)), "dd.mm.yyyy")
                Else
                    e(j + 1, num) = a(i, aColumns(j))
                End If
            Next j
        End If
    Next i
    'обратный разворот массива на 90 градусов - столбцы становятся строками
    GetTableBodyRange = WorksheetFunction.Transpose(e)
End Function
[/vba]

Тестовая процедура - в модуль листа, на котором ListBox1:
[vba]
Код
Sub test_()
    Dim a
    a = Sheets("List").ListObjects("tblOrder").DataBodyRange.Value
    Me.ListBox1.List = GetTableBodyRange(Array(1, 4, 2, 3), a)
End Sub
[/vba]

Автор - Gustav
Дата добавления - 11.01.2023 в 23:00
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Изменение размерности многомерного массива (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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