Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1
RSS
Создание списка из диапазона номеров и наоборот.
 
#1
23.10.2012 13:54:11
Приветствую!  
 
Возникла необходимость из имеющегося диапазона номеров расписать список каждого номера из данного диапазона Н/р  
1. Есть пул номеров 900808-900820 - необходимо чтобы макрос вывел эти данные списком в отдельности каждую запись. т.е.  
900808  
900809  
900810  
...  
900820  
 
Данные можно чтобы выводились хоть в этом же листе в правой от пула столбец  
 
2. Процесс обратный п.1, т.е. из списка создать пулы номеров, здесь тогда еще следует учесть что номера в списке будут не едиными пулами... Н/р.  
есть список  
 
900808  
900809  
900810  
951800  
951801  
951802  
следовательно здесь должно уже получиться 2 диапазона 900808-900810 и 951800-951802  
 
 
Задача на самом деле кроется в том что есть 2 различного вида списка, 1. расписан по пулам, а 2.рой расписан списком, и следует сравнить и скорректировать оба списка...
 
 
 
#2
23.10.2012 14:15:37
>> Возникла необходимость..., необходимо чтобы..., Задача на самом деле кроется..., следует сравнить...  
И что? Подравлять, или сочувствовать? Или это заказ? Тогда необходимо знать сумму.
Я сам - дурнее всякого примера! ...
 
 
 
#3
23.10.2012 14:22:24
В А1 900808-900820  
Sub www()  
Dim i As Long  
   i = 1  
   Cells(i, 2) = Split(Range("A1"), "-")(0)  
For i = 2 To Split(Range("A1"), "-")(1) - Split(Range("A1"), "-")(0) + 1  
   Cells(i, 2) = Cells(i - 1, 2) + 1  
Next  
End Sub
 
 
 
#4
23.10.2012 14:28:58
Ничего особо сложного нет - один список в словарь, второй проверяем по этому словарю.  
Но вот детали не ясны. Какие списки, как сравнивать, что делать по результату сравнения (вот это "сравнить и скорректировать" что подразумевает?).  
Одну деталь Сергей уже озвучил - "скорректировать" может быть не дёшево :)
 
 
 
#5
23.10.2012 14:41:58
Самое простое - свалить всё в одну кучу (в массив или на листе), отсортировать, сформировать новый список с пулами (если они нужны конечно).  
Как свалить - см.выше.  
Не будет сравнения,  будет коррекция/синхронизация.
 
 
 
#6
23.10.2012 16:55:47
Я говорил что сделать пулы дорого?  
 
Sub tt()  
   Dim cc As Range, t&, t1&, t2&, out, i&  
   For Each cc In [a1:a20]
       If t = 0 Then  
           t = cc.Value: t1 = t  
       Else  
           t2 = cc.Value  
           If t1 <> t2 Then  
               If t2 > (t1 + 1) Then  
                   If t < t1 Then out = t & "-" & t1 Else out = t  
                   i = i + 1: Cells(i, 2) = out  
                   out = Empty: t1 = t2: t = t2  
               Else  
                   t1 = t2  
               End If  
           End If  
       End If  
   Next  
   If t < t1 Then out = t & "-" & t1 Else out = t  
   i = i + 1: Cells(i, 2) = out  
End Sub  
 
Получилось неказисто, но главное что работает, да и других вариантов не вижу :)  
Весь диапазон должен быть заполнен возрастающими числами, без пустот. Повторы естественно могут быть.
 
 
 
#7
23.10.2012 18:15:51
А поискать готовое решение - не судьба?  
http://excelvba.ru/code/ExtendArray  
 
Обратите внимание на скриншот в статье - вроде бы в точности то, что вам нужно.
Надстройки для Excel  Парсинг сайтов  Мониторинг цен конкурентов
 
 
 
#8
24.10.2012 13:03:55
Попробовал испотльзовать данный скрипт от Hugo что-то не отработало. Я не программер поэтому и прошу помощи...  
 
Скрипт от кузьмича работает но только для заданного значения и расположения диапазона в ячейке А1  
 
а если у меня например есть ряд диапазонов  
900-911  
952-970  
 
то как их вывести последовательно друг за другом? т.е. расположение списка в столбце B следующего вида:  
 
900  
901  
902  
903  
...  
911  
и далее сразу  
952  
953  
954  
...  
970
 
 
 
#9
24.10.2012 13:25:32
вариант  
 
Sub ert()  
Dim x, s, i&: i = 1  
For Each x In Range("A1", Cells(Rows.Count, 1).End(xlUp)).Value  
   s = Split(x, "-")  
   With Cells(i, 2)  
       .Value = s(0): i = s(UBound(s)) - s(0) + 1  
       .AutoFill .Resize(i), xlFillSeries  
   End With  
   i = i + 1  
Next  
End Sub
 
 
 
#10
24.10.2012 14:03:52
Мой код делает "пулы" из сортированного столбца вида  
 
1  
2  
2  
3  
5  
6  
6  
7  
и т.д.  
 
Только это.  
Т.е. сперва сваливаете все пулы обоих списков в один столбец (коды есть, уже даже два), затем его сортируете, затем моим кодом получаете новые объединённые пулы.  
Сравнения между двумя исходными списками тут нет.  
Но в принципе можно сделать - но как сравнивать Вы так и не рассказали. Да и нужно ли это вообще.
 
 
 
#11
24.10.2012 14:18:57
900345-900354 900345  
902250-902252 900346  
905240-905249 900347  
906210-906219 905240  
906230-906239 905241  
909775-909799 905242  
       905243  
       905244  
       905245  
       905246  
       909775  
       909776  
       909777  
       909778  
       909779  
       909780  
       909781  
       909782  
       909783  
       909784  
       909785  
       909786  
       909787  
       909788  
       909789  
       909790  
       909791  
       909792  
       909793  
       909794  
       909795  
       909796  
       909797  
       909798  
       909799  
 
nilem - Ну вот что получается по данному скрипту, получается что последний пул/диапазон расписан в списке полностью (909775-909799), а вот например диапазон 902250-902252,906210-906219 и 906230-906239 - отсутствуют полностью, остальные расписаны сокращенно
 
 
 
#12
24.10.2012 14:21:32
К сожалению в предыдущем сообщении не сохранилось расположение "пробелов" - поэтому прошло смещение  
первый столбец диапазоны, соответственно второй столбец список полученных номеров после отработки скрипта
 
 
 
#13
24.10.2012 14:26:39
Hugo я еще раз повторюсь я не программер и заниматься изучением VBA с нуля - ну это просто очень долго... я не смогу разобраться думаю даже за 1 день с полным пониманием Вашего скрипта, хотя могу и ошибаться... ошибка отработки    
Sub tt()  
Dim cc As Range, t&, t1&, t2&, out, i&  
For Each cc In [a1:a20]
If t = 0 Then  
t = cc.Value: t1 = t  
Else  
t2 = cc.Value  
If t1 <> t2 Then  
If t2 > (t1 + 1) Then  
If t < t1 Then out = t & "-" & t1 Else out = t  
i = i + 1: Cells(i, 2) = out  
out = Empty: t1 = t2: t = t2  
Else  
t1 = t2  
End If  
End If  
End If  
Next  
If t < t1 Then out = t & "-" & t1 Else out = t  
i = i + 1: Cells(i, 2) = out  
End
 
 
 
#14
24.10.2012 14:38:06
Файла/таблицы не вижу. Что там в этой ячейке-cc (в A1) в этот момент? Судя по всему текст, хотя я такой ошибки не добился, как ни старался.  
Ну и код ещё нужно доработать (или изменить вручную текст) - чтоб вместо [a1:a20] брался нужный непрерывный диапазон чисел.
Пулы должны появиться в столбце B начиная с B1.
 
 
 
#15
24.10.2012 14:39:43
Rotmir1  
да, ошибочка вкралась (это потому что короткий ert :)  
Вот так д.б. правильно, попробуйте еще раз  
 
Sub ertert()  
Dim x, s, i&, j&: i = 1  
For Each x In Range("A1", Cells(Rows.Count, 1).End(xlUp)).Value  
   s = Split(x, "-")  
   With Cells(i, 2)  
       .Value = s(0): j = s(UBound(s)) - s(0) + 1  
       .AutoFill .Resize(j), xlFillSeries  
   End With  
   i = i + j  
Next  
End Sub
 
 
 
#16
24.10.2012 14:40:04
Вот файл
 
 
 
#17
24.10.2012 14:47:03
С моим кодом понятно - я же писал, что он делает! Делает пулы, а не из пулов :)
 
 
 
#18
24.10.2012 14:50:20
Проверил - сперва ertertом из пулов получаем столбец номеров, затем из этого столбца (из [a1:a68]) моим кодом опять получаем те же пулы. Работает.
 
 
 
#19
24.10.2012 14:59:13
nilem - Благодарю - теперь вроде бы работает правильно, еще вопросик, а если пуллы будут большими например несколько сотен - точно длины хватит?  
 
Hugo - тоже благодарность за помощь! но не совсем корректно отрабатывает скрипт... Начальный пул перевел скриптом nilem'a, а вот обратно Вашим получилось не все... Файл прикрепляю
 
 
 
#20
24.10.2012 16:05:59
Ну я же написал - в диапазоне [a1:a68]! Хотя файл без макроса - но я телепат :)
Хотя можно так эту строку написать - если ниже последнего числа нигде ничего нет:  
 
   For Each cc In [a1].CurrentRegion.Columns(1).Cells
 
Будет всё брать самостоятельно.
 
 
 
#21
25.10.2012 09:10:03
"... а если пуллы будут большими например несколько сотен - точно длины хватит?"  
тогда массивы  
 
Sub ertert()  
Dim x, a, y(), s, i&, j&, t&  
a = Range("A1", Cells(Rows.Count, 1).End(xlUp)).Value  
If Not IsArray(a) Then Exit Sub  
Const u As Long = 1000: ReDim y(1 To u, 1 To 1): j = 1  
For Each x In a  
   s = Split(x, "-")  
   For t = s(0) To s(1)  
       i = i + 1  
       If i > u Then j = j + 1: i = 1: ReDim Preserve y(1 To u, 1 To j)  
       y(i, j) = t  
   Next t  
Next x  
With Range("C1")  
   .CurrentRegion.ClearContents: .Resize(IIf(j > 1, u, i), j).Value = y()  
End With  
End Sub  
 
вот здесь:  
Const u As Long = 1000  
1000 - кол-во строк в выходном массиве - задайте, как нужно
 
 
 
Страницы: 1
Читают тему
Наверх