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

Вход

Регистрация

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

 

= Мир MS Excel/перевести данные из одномерного массива в двумерный - Мир MS Excel

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

Excel 2013
Добрый вечер. Появилась необходимость перевести данные из одномерного массива в двумерный, функцией =счётслимн() считает слишком долго. Видел что делают с помощью vba, но так и не смог разобраться в этом. Если кто то может помочь буду очень благодарен. На лист1 одномерный массив с данными(фамилия, дата и №Трассы) необходимо в Лист2 начиная с ячейки L3 посчитать количество повторений №Трассы у каждой фамилии отдельно, притом если дата последней записи для данной фамилии более 14 дней, то эти данные не вставлять т.е. =""
К сообщению приложен файл: 2017.xls (31.5 Kb)
 
Ответить
СообщениеДобрый вечер. Появилась необходимость перевести данные из одномерного массива в двумерный, функцией =счётслимн() считает слишком долго. Видел что делают с помощью vba, но так и не смог разобраться в этом. Если кто то может помочь буду очень благодарен. На лист1 одномерный массив с данными(фамилия, дата и №Трассы) необходимо в Лист2 начиная с ячейки L3 посчитать количество повторений №Трассы у каждой фамилии отдельно, притом если дата последней записи для данной фамилии более 14 дней, то эти данные не вставлять т.е. =""
Автор - Anton85
Дата добавления - 07.01.2017 в 21:16
Manyasha Дата: Воскресенье, 08.01.2017, 20:02 | Сообщение № 2
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
Anton85, здравствуйте, так подойдет?
[vba]
Код
Sub macro()
    Dim sh1 As Worksheet, sh2 As Worksheet, fio()
    Dim lr1&, lr2&, data, i&, dic As Object
    Set sh1 = ThisWorkbook.Sheets("Лист1")
    Set sh2 = ThisWorkbook.Sheets("Лист2")
    With sh1
        lr1 = .Cells(Rows.Count, 1).End(xlUp).Row
        data = .Cells(2, 1).Resize(lr1 - 1, 3).Value
        Set dic = CreateObject("scripting.dictionary")
        For i = 1 To UBound(data)
            If Date - data(i, 2) <= 14 Then
                If dic.exists(Trim(data(i, 1))) Then
                    fio = dic(Trim(data(i, 1)))
                Else
                    Erase fio
                    ReDim fio(9)
                End If
                fio(data(i, 3) - 1) = fio(data(i, 3) - 1) + 1
                dic(Trim(data(i, 1))) = fio
            End If
        Next i
    End With
    With sh2
        lr2 = .Cells(Rows.Count, 2).End(xlUp).Row
        For i = 3 To lr2
            .Cells(i, "l").Resize(, 10).ClearContents
            .Cells(i, "l").Resize(, 10) = dic(Trim(.Cells(i, 2)))
        Next i
    End With
End Sub
[/vba]
К сообщению приложен файл: 2017-1.xls (51.0 Kb)

ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеAnton85, здравствуйте, так подойдет?
[vba]
Код
Sub macro()
    Dim sh1 As Worksheet, sh2 As Worksheet, fio()
    Dim lr1&, lr2&, data, i&, dic As Object
    Set sh1 = ThisWorkbook.Sheets("Лист1")
    Set sh2 = ThisWorkbook.Sheets("Лист2")
    With sh1
        lr1 = .Cells(Rows.Count, 1).End(xlUp).Row
        data = .Cells(2, 1).Resize(lr1 - 1, 3).Value
        Set dic = CreateObject("scripting.dictionary")
        For i = 1 To UBound(data)
            If Date - data(i, 2) <= 14 Then
                If dic.exists(Trim(data(i, 1))) Then
                    fio = dic(Trim(data(i, 1)))
                Else
                    Erase fio
                    ReDim fio(9)
                End If
                fio(data(i, 3) - 1) = fio(data(i, 3) - 1) + 1
                dic(Trim(data(i, 1))) = fio
            End If
        Next i
    End With
    With sh2
        lr2 = .Cells(Rows.Count, 2).End(xlUp).Row
        For i = 3 To lr2
            .Cells(i, "l").Resize(, 10).ClearContents
            .Cells(i, "l").Resize(, 10) = dic(Trim(.Cells(i, 2)))
        Next i
    End With
End Sub
[/vba]
Автор - Manyasha
Дата добавления - 08.01.2017 в 20:02
bmv98rus Дата: Воскресенье, 08.01.2017, 20:20 | Сообщение № 3
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4111
Репутация: 768 ±
Замечаний: 0% ±

Excel 2013/2016
Anton85,

А какие объемы данных у вас? просто
Код
=COUNTIFS(Лист1!$C:$C;L$2;Лист1!$A:$A;$B4;Лист1!$B:$B;">" &TODAY()-14)

работает вполне сносно. конечно если у вас не под миллион строк даных.

Или сперва сводную сделать встроенными средствами и из нее брать данные, если уж пересчет долгий.
К сообщению приложен файл: Copy_of_2017.xls (39.5 Kb)

Замечательный Временно просто медведь , процентов на 20.

Сообщение отредактировал bmv98rus - Воскресенье, 08.01.2017, 20:43
 
Ответить
СообщениеAnton85,

А какие объемы данных у вас? просто
Код
=COUNTIFS(Лист1!$C:$C;L$2;Лист1!$A:$A;$B4;Лист1!$B:$B;">" &TODAY()-14)

работает вполне сносно. конечно если у вас не под миллион строк даных.

Или сперва сводную сделать встроенными средствами и из нее брать данные, если уж пересчет долгий.
Автор - bmv98rus
Дата добавления - 08.01.2017 в 20:20
Anton85 Дата: Воскресенье, 08.01.2017, 21:12 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 14
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
bmv98rus, вот именно что одна строка это более 5000 ячеек, а фамилий около 60 пока, но возможно будет и больше
 
Ответить
Сообщениеbmv98rus, вот именно что одна строка это более 5000 ячеек, а фамилий около 60 пока, но возможно будет и больше
Автор - Anton85
Дата добавления - 08.01.2017 в 21:12
Anton85 Дата: Воскресенье, 08.01.2017, 21:20 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 14
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Manyasha, почти))) а можно там где пусто поставить нули? Ну и чтоб совсем обнаглеть, сделать так чтоб цифра в ячейке была не больше 10

а так почти идеально
единственный минус смотрю, на код, и не черта не понимаю......... то ли не дорос еще до этого, то ли мозги не под это заточены)))
 
Ответить
СообщениеManyasha, почти))) а можно там где пусто поставить нули? Ну и чтоб совсем обнаглеть, сделать так чтоб цифра в ячейке была не больше 10

а так почти идеально
единственный минус смотрю, на код, и не черта не понимаю......... то ли не дорос еще до этого, то ли мозги не под это заточены)))
Автор - Anton85
Дата добавления - 08.01.2017 в 21:20
bmv98rus Дата: Воскресенье, 08.01.2017, 21:59 | Сообщение № 6
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4111
Репутация: 768 ±
Замечаний: 0% ±

Excel 2013/2016
Anton85,

Вы попобуйте со сводной таблицей, 5000 строк и 60 фамилий - это не те объемы. Буквально на днях переделывал таблицу которая просто по процентику в несколько секунд считала. Там более 300000 строк и условий было более 5.

Замечательный Временно просто медведь , процентов на 20.
 
Ответить
СообщениеAnton85,

Вы попобуйте со сводной таблицей, 5000 строк и 60 фамилий - это не те объемы. Буквально на днях переделывал таблицу которая просто по процентику в несколько секунд считала. Там более 300000 строк и условий было более 5.
Автор - bmv98rus
Дата добавления - 08.01.2017 в 21:59
Manyasha Дата: Понедельник, 09.01.2017, 12:03 | Сообщение № 7
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
Цитата bmv98rus, 08.01.2017 в 21:59, в сообщении № 6 ()
там где пусто поставить нули

при объявлении массива fio, укажите тип
[vba]
Код
fio() As Integer
[/vba]
Цитата Anton85, 08.01.2017 в 21:20, в сообщении № 5 ()
сделать так чтоб цифра в ячейке была не больше 10

[vba]
Код
fio(data(i, 3) - 1) = Application.Min(10, fio(data(i, 3) - 1) + 1)
[/vba]
Код прокомментировала:
[vba]
Код
Sub macro()
    Dim sh1 As Worksheet, sh2 As Worksheet, fio() As Integer
    Dim lr1&, lr2&, data, i&, dic As Object
    Set sh1 = ThisWorkbook.Sheets("Лист1")
    Set sh2 = ThisWorkbook.Sheets("Лист2")
    With sh1
        'последняя строка на листе 1
        lr1 = .Cells(Rows.Count, 1).End(xlUp).Row
        'Запоминаем данные из трех столбцов в массив
        data = .Cells(2, 1).Resize(lr1 - 1, 3).Value
        'Будем заполнять словарик, где для каждого ключа (фамилии) у нас будет массив значений (кол-во записей для каждого номера трассы)
        Set dic = CreateObject("scripting.dictionary")
        For i = 1 To UBound(data)
            'Если разница между сегодняшней датой и датой на листе 1 <= 14
            If Date - data(i, 2) <= 14 Then
                'Если текущая фамилия уже есть в словаре, запоминаем в массив fio все значения для этого ключа (фамилии)
                If dic.exists(Trim(data(i, 1))) Then
                    fio = dic(Trim(data(i, 1)))
                'Иначе, очищаем массив fio
                Else
                   Erase fio
                   ReDim fio(9)
                End If
                'Увеличиваем кол-во с текущим номером трассы на 1
                fio(data(i, 3) - 1) = Application.Min(10, fio(data(i, 3) - 1) + 1)
                'Обновляем/создаем элемент словаря для текущей вамилии
                dic(Trim(data(i, 1))) = fio
            End If
        Next i
    End With
    With sh2
        'последняя строка на листе 2
        lr2 = .Cells(Rows.Count, 2).End(xlUp).Row
        For i = 3 To lr2
            'очищаем строчку от старых значений
            .Cells(i, "l").Resize(, 10).ClearContents
            'записываем новые значения
            .Cells(i, "l").Resize(, 10) = dic(Trim(.Cells(i, 2)))
        Next i
    End With
End Sub
[/vba]
К сообщению приложен файл: 2017-2.xls (42.5 Kb)

ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщение
Цитата bmv98rus, 08.01.2017 в 21:59, в сообщении № 6 ()
там где пусто поставить нули

при объявлении массива fio, укажите тип
[vba]
Код
fio() As Integer
[/vba]
Цитата Anton85, 08.01.2017 в 21:20, в сообщении № 5 ()
сделать так чтоб цифра в ячейке была не больше 10

[vba]
Код
fio(data(i, 3) - 1) = Application.Min(10, fio(data(i, 3) - 1) + 1)
[/vba]
Код прокомментировала:
[vba]
Код
Sub macro()
    Dim sh1 As Worksheet, sh2 As Worksheet, fio() As Integer
    Dim lr1&, lr2&, data, i&, dic As Object
    Set sh1 = ThisWorkbook.Sheets("Лист1")
    Set sh2 = ThisWorkbook.Sheets("Лист2")
    With sh1
        'последняя строка на листе 1
        lr1 = .Cells(Rows.Count, 1).End(xlUp).Row
        'Запоминаем данные из трех столбцов в массив
        data = .Cells(2, 1).Resize(lr1 - 1, 3).Value
        'Будем заполнять словарик, где для каждого ключа (фамилии) у нас будет массив значений (кол-во записей для каждого номера трассы)
        Set dic = CreateObject("scripting.dictionary")
        For i = 1 To UBound(data)
            'Если разница между сегодняшней датой и датой на листе 1 <= 14
            If Date - data(i, 2) <= 14 Then
                'Если текущая фамилия уже есть в словаре, запоминаем в массив fio все значения для этого ключа (фамилии)
                If dic.exists(Trim(data(i, 1))) Then
                    fio = dic(Trim(data(i, 1)))
                'Иначе, очищаем массив fio
                Else
                   Erase fio
                   ReDim fio(9)
                End If
                'Увеличиваем кол-во с текущим номером трассы на 1
                fio(data(i, 3) - 1) = Application.Min(10, fio(data(i, 3) - 1) + 1)
                'Обновляем/создаем элемент словаря для текущей вамилии
                dic(Trim(data(i, 1))) = fio
            End If
        Next i
    End With
    With sh2
        'последняя строка на листе 2
        lr2 = .Cells(Rows.Count, 2).End(xlUp).Row
        For i = 3 To lr2
            'очищаем строчку от старых значений
            .Cells(i, "l").Resize(, 10).ClearContents
            'записываем новые значения
            .Cells(i, "l").Resize(, 10) = dic(Trim(.Cells(i, 2)))
        Next i
    End With
End Sub
[/vba]
Автор - Manyasha
Дата добавления - 09.01.2017 в 12:03
Мир MS Excel » Вопросы и решения » Вопросы по VBA » перевести данные из одномерного массива в двумерный (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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