Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 14.09.2013, 17:53   #1
TimeStopper
Пользователь
 
Регистрация: 11.09.2012
Сообщений: 44
По умолчанию Разобрать столбец по адресам.

Здравствуйте, помогите сделать выборку ...
Есть столбец. Нечетная строчка - адрес элемента (от 1 до n). Четная строчка - номер элемента.
Мне надо получить все адреса всех элементов.
К примеру элемент
1: состоит в адресах 4,5,8,14,257
2: состоит в адресах 7,15,24,47
и так по каждому элементу...
Адресов в таблице бывает до тысячи, элементов до сотни...всегда по разному...

Речь идет о первом столбце, во вложенном файле...
Вложения
Тип файла: rar Подбор армирования АСКГ1.rar (98.2 Кб, 8 просмотров)
TimeStopper вне форума Ответить с цитированием
Старый 16.09.2013, 11:01   #2
TimeStopper
Пользователь
 
Регистрация: 11.09.2012
Сообщений: 44
По умолчанию

господа программисты, это такой сложный скрипт? )
а сколько будет стоить его сделать? )

Последний раз редактировалось TimeStopper; 16.09.2013 в 11:36.
TimeStopper вне форума Ответить с цитированием
Старый 16.09.2013, 11:13   #3
kuklp
Участник клуба
 
Регистрация: 02.05.2010
Сообщений: 1,390
По умолчанию

Попробуйте перезалить файл. Не могу скачать.
mailto: kuklp60@gmail.com, ящики для благодарностей:
WM Z206653985942, R334086032478, U238399322728
kuklp вне форума Ответить с цитированием
Старый 17.09.2013, 07:59   #4
TimeStopper
Пользователь
 
Регистрация: 11.09.2012
Сообщений: 44
По умолчанию

Попробуйте вот этот файл скачать )
Вложения
Тип файла: rar Подбор армирования АСКГ1.rar (98.2 Кб, 11 просмотров)
TimeStopper вне форума Ответить с цитированием
Старый 17.09.2013, 09:03   #5
SAS888
Старожил
 
Аватар для SAS888
 
Регистрация: 05.12.2007
Сообщений: 4,180
По умолчанию

Активируйте требуемый лист (в Вашем примере с 1 по 11) и запустите следующий макрос:
Код:
Sub qq()
    Dim i As Long, a(), x As Dictionary: Set x = New Dictionary
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    a = Range("A3:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    For i = 1 To UBound(a, 1) Step 2
        If x.Exists(a(i + 1, 1)) Then x.Item(a(i + 1, 1)) = x.Item(a(i + 1, 1)) & ", " & a(i, 1) Else x.Add a(i + 1, 1), a(i, 1)
    Next
    On Error Resume Next: Sheets("Результат_" & ActiveSheet.Name).Delete: On Error GoTo 0
    Sheets.Add.Name = "Результат_" & ActiveSheet.Name
    Range("A1:A" & x.Count).Value = Application.Transpose(x.Keys): Range("B1:B" & x.Count).Value = Application.Transpose(x.Items)
    [A:A].HorizontalAlignment = xlCenter: [B:B].HorizontalAlignment = xlLeft: Columns("B").AutoFit
End Sub
Будет создан (либо заменен) лист с соответствующими результатами. Если нужно сделать одну процедуру для всех листов - "прикрутите" цикл по требуемым листам.
Пример во вложении.
Вложения
Тип файла: rar Подбор армирования АСКГ1_2.rar (94.5 Кб, 10 просмотров)
Чем шире угол зрения, тем он тупее.

Последний раз редактировалось SAS888; 17.09.2013 в 12:08.
SAS888 вне форума Ответить с цитированием
Старый 17.09.2013, 14:05   #6
TimeStopper
Пользователь
 
Регистрация: 11.09.2012
Сообщений: 44
По умолчанию

Огромное спасибо! Программисты - двигатель прогресса )
TimeStopper вне форума Ответить с цитированием
Старый 23.09.2013, 17:22   #7
TimeStopper
Пользователь
 
Регистрация: 11.09.2012
Сообщений: 44
По умолчанию

Я вот столкнулся со следующей проблемой... сам по себе этот скрипт работает нормально.
Но для удобства работы, я все скрипты переношу в личную книгу макросов...
А оттуда он работать отказывается. "user - defined type not defined"
В Гугле нашел ответ, что надо подключить какую-то библиотеку в Reference, но почему то эта функция меню неактивна, я не могу ее запустить...
TimeStopper вне форума Ответить с цитированием
Старый 26.09.2013, 09:24   #8
SAS888
Старожил
 
Аватар для SAS888
 
Регистрация: 05.12.2007
Сообщений: 4,180
По умолчанию

Нужно либо подключить библиотеку "Microsoft Scripting Runtime", либо объявлять словарь по ходу программы. Для этого, строку
Код:
Dim i As Long, a(), x As Dictionary: Set x = New Dictionary
замените на
Код:
Dim i As Long, a(), x: Set x = CreateObject("Scripting.Dictionary")
Чем шире угол зрения, тем он тупее.

Последний раз редактировалось SAS888; 26.09.2013 в 10:10.
SAS888 вне форума Ответить с цитированием
Старый 11.01.2014, 16:31   #9
TimeStopper
Пользователь
 
Регистрация: 11.09.2012
Сообщений: 44
По умолчанию

Большое спасибо!!
Я просто не программист, может кто нибудь помочь прикруть этот цикл? )
Ну тоесть что бы в итоге получался всего 1 результирующий лист, с выборкой из всех рабочих

Последний раз редактировалось TimeStopper; 11.01.2014 в 16:41.
TimeStopper вне форума Ответить с цитированием
Старый 11.01.2014, 19:03   #10
SAS888
Старожил
 
Аватар для SAS888
 
Регистрация: 05.12.2007
Сообщений: 4,180
По умолчанию

1. Необходимо знать, какие из существующих в книге листов нужно обрабатывать, а какие не трогать.
2. Т.к. в результате обработки всех листов отдельные значения словаря (массива значений) могут содержать более 911 символов (что и происходит в данном примере), то вывод этих значений на лист нужно делать поэлементно.

Обработать все листы, содержащие в своем имени число (в вашем файле это листы с именами "1"..."11") можно так:
Код:
Sub qq()
    Dim i As Long, ws As Worksheet, a(), b(), x
    Set x = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    On Error Resume Next: Sheets("Результат").Delete: On Error GoTo 0
    For Each ws In ThisWorkbook.Sheets
        If Val(ws.Name) <> 0 Then
            a = ws.Range("A3:A" & ws.Cells(Rows.Count, 2).End(xlUp).Row).Value
            For i = 1 To UBound(a, 1) Step 2
                If x.Exists(a(i + 1, 1)) Then x.Item(a(i + 1, 1)) = x.Item(a(i + 1, 1)) & ", " & a(i, 1) Else x.Add a(i + 1, 1), a(i, 1)
            Next
        End If
    Next
    Sheets.Add.Name = "Результат"
    a = x.Keys: b = x.Items
    For i = 0 To UBound(a, 1)
        Cells(i + 1, 1) = a(i): Cells(i + 1, 2) = b(i)
    Next
    [A:A].HorizontalAlignment = xlCenter: [B:B].HorizontalAlignment = xlLeft: Columns("B").AutoFit
End Sub
Пример во вложении.
Вложения
Тип файла: rar Подбор армирования АСКГ1_3.rar (96.4 Кб, 7 просмотров)
Чем шире угол зрения, тем он тупее.

Последний раз редактировалось SAS888; 11.01.2014 в 19:10.
SAS888 вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Служба электронных рассылок по почтовым адресам lideradv Общие вопросы Delphi 0 30.08.2012 05:51
Разобрать сайт Rost93 Свободное общение 4 16.06.2012 20:13
Ошибка. НЕ МОГУ ВСТАВИТЬ столбец В ЗАДАЧУ КОТОРАЯ ВЫВЕДЕТ СТОЛБЕЦ ИЗ ЕДИНИЦ ПОСЛЕ ЧИСЛА к. Диас_ Паскаль, Turbo Pascal, PascalABC.NET 1 14.06.2011 18:49
макрос который будет копировать столбец А из закрытой книги Данные, и вставлять в книгу Сток в столбец B Utirka66 Microsoft Office Excel 8 06.07.2009 09:53