Форум программистов, компьютерный форум, киберфорум
Наши страницы
VBA
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг 4.50/14: Рейтинг темы: голосов - 14, средняя оценка - 4.50
zigmund5
0 / 0 / 0
Регистрация: 06.11.2013
Сообщений: 9
1

Поиск и выборка данных из массива с распределением по разным листам, согласно условию отбора

06.11.2013, 15:40. Просмотров 2539. Ответов 30
Метки нет (Все метки)

Добрый день.
Подскажите, пожалуйста, как можно решить задачу с выборкой данных с общего листа и распределение этих данных по другим листам, согласно выставленным условиям?
На первом (основном ) листе в столбце №1 указаны номера кабинетов, в которых сидят сотрудники (причем в одном и том же кабинете сидит несколько сотрудников, кабинеты указаны вразнобой и их нельзя упорядочить). В столбце №2 указаны фамилии сотрудников. Таким образом, напротив каждого номера кабинета расположена фамилия сотрудника. Пример:
43 Иванов
44 Петров
45 Сидоров
44 Смирнов
Т.е. в кабинете 43 сидит Иванов, в кабинете 44 – Петров и Смирнов, в кабинете 45 – Сидоров.
Остальным листам присвоены наименования согласно номеру кабинета. На выходе должно получиться : на листе 43 одна строка со значением Иванов, на листе 44 – две строки Петров и Смирнов, на листе 45 – Сидоров.
0
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
06.11.2013, 15:40
Ответы с готовыми решениями:

Выборка данных из текста по условию
Всем привет, требуется перенести данные в блокнот в таком порядке как в примере...

Удаление по двойному условию + перебор по листам
Доброго всем дня! Нашел на просторах интернета макрос: Sub по_2условию() ...

Оптимизация условий отбора данных с таблицы по разным критериям
Всем привет. Есть таблица-классификатор, в которой досконально...

Из одной таблицы разнести данные по разным листам
Здравствуйте. Есть таблица "отгрузки" с данными. Необходимо разнести из нее...

Вычислить сумму элементов массива согласно условию
В одномерном массиве А(10) вычислить сумму элементов массива, отличающихся от...

30
zigmund5
0 / 0 / 0
Регистрация: 06.11.2013
Сообщений: 9
08.11.2013, 16:03  [ТС] 21
Пока вопрос один - как срастить желаемое с возможным.
0
Igor_Tr
4369 / 653 / 36
Регистрация: 17.01.2010
Сообщений: 2,134
08.11.2013, 16:06 22
Не понял вопрос.
0
Igor_Tr
4369 / 653 / 36
Регистрация: 17.01.2010
Сообщений: 2,134
08.11.2013, 16:07 23
Ага! Теперь понял. Почему- не прикрепился файл?????
1
Вложения
Тип файла: rar New_ТЗ.rar (25.7 Кб, 10 просмотров)
Igor_Tr
4369 / 653 / 36
Регистрация: 17.01.2010
Сообщений: 2,134
08.11.2013, 23:23 24
Или я после поля такой тупой, или что-то другое. Опять я не понял. Спасибо - это ооочень хорошо и вкусно , но меня больше интересует или работает.
0
zigmund5
0 / 0 / 0
Регистрация: 06.11.2013
Сообщений: 9
08.11.2013, 23:34  [ТС] 25
я отписал,что все круто и все работает,видимо не прошла связь) Спасибо.

Добавлено через 3 минуты
Есть еще пару идей, но нужно их правильно сформулировать. По программе возьму период 4-5 дней жесткого тестирования.
0
Igor_Tr
4369 / 653 / 36
Регистрация: 17.01.2010
Сообщений: 2,134
08.11.2013, 23:54 26
Я радый, конечно. Одно но... Вы зря отказались от помощи Hugo121 (кстати, это под его настойчивым влиянием я занялся словарями). У него всегда очень толковые замечания, или свои варианты. Возможно, это отпугнуло других. Смотрите, вокруг тишина. Никто не поправляет, не критикует, не подсказывает, не рекомендует... Как в Неваде после испытаний. А я люблю, что б куча красок, мнений, дискусий... Тогда, может, и я, и Вы узнали бы много нового. А так, мы как два нарциса. Один гордо спрашивает, другой так умно отвечает... Но это так... Может, на будущее.
0
Hugo121
6308 / 2402 / 411
Регистрация: 19.10.2012
Сообщений: 7,126
09.11.2013, 03:38 27
Тёзка, привет!
Не было времени вникать, да и лениво...
Но вот наш совместный вариант - чуть попаразитировал где мог, остальное кажется упростил
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
Option Explicit
 
Sub tt()
    Dim a(), secDict As Object, ntDict As Object, i&, ii&, ind&
    Dim elS, elN, x&
 
    Set secDict = CreateObject("scripting.dictionary"): secDict.comparemode = 1
    Set ntDict = CreateObject("scripting.dictionary"): ntDict.comparemode = 1
    On Error Resume Next
 
    a = Sheets("лист для заливки массива").[a1].CurrentRegion.Value
    For i = 2 To UBound(a)
 
        If Not secDict.exists(a(i, 4)) Then secDict.Add a(i, 4), New Collection
        secDict.Item(a(i, 4)).Add a(i, 1), CStr(a(i, 1))   'в коллекцию сектора добавляем номер точки
 
        'использую исходный массив для сводных данных
        If Not ntDict.exists(a(i, 1)) Then
            ind = ind + 1
            ntDict.Item(a(i, 1)) = ind    'в словарь номеров точек кладём индексы сводной
            a(ind, 1) = a(i, 1)
            a(ind, 2) = a(i, 3)
            a(ind, 3) = a(i, 2)
        Else
            ii = ntDict.Item(a(i, 1))
            a(ii, 3) = a(ii, 3) + a(i, 2)
        End If
 
    Next
 
    Application.ScreenUpdating = False
    For Each elS In secDict.keys
        If Not fun_SheetExists(CStr(elS)) Then
            With Sheets.Add: .Name = CStr(elS): End With
        End If
        With Sheets(CStr(elS))
            .Cells.Clear
            i = 1
            .Cells(i).Resize(1, 3) = Array("Номер точки", "Адрес разгрузки", "Вес, кг")
            For Each elN In secDict.Item(elS)
                i = i + 1
                x = ntDict.Item(elN)
                .Cells(i, 1) = a(x, 1): .Cells(i, 2) = a(x, 2): .Cells(i, 3) = a(x, 3)
            Next
 
            .UsedRange.Columns.AutoFit
            .ListObjects.Add(xlSrcRange, .UsedRange, , xlYes).Name = CStr(elS)
            .ListObjects(CStr(elS)).TableStyle = "TableStyleMedium2"
            .ListObjects(CStr(elS)).ShowTotals = True
        End With    'Sheets(CStr(Elt))
    Next    ' elS
 
    Application.ScreenUpdating = True
    
    secDict.RemoveAll
    Set secDict = Nothing
    ntDict.RemoveAll
    Set ntDict = Nothing
 
    MsgBox Space(10) & "D O N E!"
 
End Sub
 
Private Function fun_SheetExists(sname) As Boolean
    Dim wSht As Worksheet
    On Error Resume Next
    Set wSht = ActiveWorkbook.Sheets(sname)
    If Err = 0 Then fun_SheetExists = True _
       Else fun_SheetExists = False
    On Error GoTo 0
End Function
Если выгружаемых данных тысячи строк - то к выгрузке тоже можно прикрутить массив, будет быстрее.
Если не много - то прикручивать лениво
1
Igor_Tr
4369 / 653 / 36
Регистрация: 17.01.2010
Сообщений: 2,134
09.11.2013, 10:23 28
To Hugo. Я считал, что если Set ntDict = Nothing, тогда ntDict.RemoveAll (именно в такой ситуации) лишнее. Убиваем ведь сразу, гуманно. А вот то, что считал, что суб дикт, как составной, убивается паралельно - явно ошибка. Теперь посмотрел в Locals... Да, нужен еще один патрон.
0
Hugo121
6308 / 2402 / 411
Регистрация: 19.10.2012
Сообщений: 7,126
09.11.2013, 18:08 29
Вообще-то я не уверен, что необходимо сперва очищать словарь - но лишним не будет, и времени много не займёт.
Можно посмотреть, что там будет с памятью с очисткой и без неё - но как-нибудь в другой раз
Может быть кто-то точно знает, как правильно?
0
Igor_Tr
4369 / 653 / 36
Регистрация: 17.01.2010
Сообщений: 2,134
09.11.2013, 18:32 30
Я не проверял, просто побегал по глобусу. Замеры не нашел, но везде, при выходах из процедур, просто Set ... = Nothing. Это же рекомендует и Patrick G. Matthews, в т.ч.
0
Hugo121
6308 / 2402 / 411
Регистрация: 19.10.2012
Сообщений: 7,126
09.11.2013, 19:14 31
Да, опытным путём эффекта от RemoveAll не обнаружено!
Значит можно сэкономить миллисекунду.

Добавлено через 8 минут
Хотя померил время на 100к строк - если не делать RemoveAll, то почти столько же времени тратится на nothing.
1
09.11.2013, 19:14
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
09.11.2013, 19:14

Массив: Вывод на экран массива согласно условию
var a:arrayof integer; i,j,x,n,p,k:integer; begin write('n='); readln(n);...

Считать данные из файла в два массива согласно условию
В файле исходных данных содержится одномерный массив A(2n). Написать, отладить...

Сформировать матрицу из исходного одномерного массива согласно условию
не получается, кто разбирается, помогите с решением


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
31
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2018, vBulletin Solutions, Inc.
Рейтинг@Mail.ru