Множественное вхождение регионов(range) - Мир MS Excel

Регистрация

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

= Мир MS Excel/Множественное вхождение регионов(range) - Мир MS Excel

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Множественное вхождение регионов(range)

Множественное вхождение регионов(range)

Дата: Суббота, 16.03.2013, 19:56 | Сообщение № 1

Группа: Пользователи

Ранг: Новичок

Сообщений: 15

Репутация: 0 ±

Замечаний: 0% ±

Может кто сказать как найти Каждое вхождение региона 1 в регион 2?

Intersect выдает только пересечение. Нужно каждое вхождение одного региона в другой (желательно чтобы выдавалось в виде нового объекта - региона, как при пересечении)

пробовал код типа
[vba]

Код

For Each rngTreug In rngBig
rngTreug.Interior.ColorIndex = 5 'закрасить синим
Next

[/vba]

результат отрицательный

Ответить

Дата: Суббота, 16.03.2013, 20:15 | Сообщение № 2

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2757

Репутация: 1139 ±

Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1

Пока ничо не понятно... Нарисуйте, пожалуйста, пример: регион 2 закрасьте цветовой заливкой, а регион 1 - изобразите цифрами в ячейках, причем, очередное "каждое вхождение" другой цифрой, начиная с 1.

Я приложил "примерный пример": жёлтое - диапазон 2, 1 - диапазон 1, жирный шрифт - их пересечение.

Рискну предположить, что, может, Вам различные области одного диапазона нужны, т.е. Range.Areas ?

К сообщению приложен файл: Intersect12.xls (19.5 Kb)

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

Сообщение отредактировал Gustav - Суббота, 16.03.2013, 20:24

Ответить

Дата: Суббота, 16.03.2013, 20:53 | Сообщение № 3

Группа: Пользователи

Ранг: Новичок

Сообщений: 15

Репутация: 0 ±

Замечаний: 0% ±

Gustav, [vba]

Код

Private Sub CommandButton1_Click()
Dim NomCol As Integer
Dim DlRebra As Integer
Dim NadstrH As Integer
Dim RecCount As Integer
Dim a As Integer

'Sheet.Unprotect
Application.ScreenUpdating = False

RecCount = Sheets("0").Range("B1")
'NomCol = TextBox1.Value
'DlRebra = TextBox2.Value
'VisNadstr = TextBox3.Value

NomCol = 4
DlRebra = 4
VisNadstr = 10

Dim rngTreug As Range, Rng1 As Range, rngBig, RngPeresech, RngT As Range

a = NomCol - DlRebra + 1
Set rngBig = Range(Cells(1, 4 * (a - 1) + 2).Address(False, False), Cells(RecCount - a + 1, 4 * a + 1).Address(False, False))
For a = NomCol - DlRebra + 1 + 1 To DlRebra
     Set Rng1 = Range(Cells(1, 4 * (a - 1) + 2).Address(False, False), Cells(RecCount - a + 1, 4 * a + 1).Address(False, False))
     Set rngBig = Union(Rng1, rngBig)
Next

a = NomCol - DlRebra + 1
Set rngTreug = Range(Cells(RecCount - DlRebra + 1, 4 * (a - 1) + 2).Address(False, False), Cells(RecCount - a + 1, 4 * a + 1).Address(False, False))
For a = NomCol - DlRebra + 1 + 1 To DlRebra
    Set Rng1 = Range(Cells(RecCount - DlRebra + 1, 4 * (a - 1) + 2).Address(False, False), Cells(RecCount - a + 1, 4 * a + 1).Address(False, False))
    Set rngTreug = Union(Rng1, rngTreug)
Next

rngBig.Interior.ColorIndex = 6
rngTreug.Interior.ColorIndex = 4

Dim N As Double
Dim K As Integer
Dim S1 As Integer
Dim S2 As Integer
N = 0

'Set Rng1 = Intersect(rngBig, rngTreug)
'Rng1.Interior.ColorIndex = 5

'For K = 2 To RecCount
  '   Set RngT = rngTreug.Offset(2 - K, 0)
   '  Set RngPeresech = Intersect(RngT, rngTreug)

     'RngT.Interior.ColorIndex = 5
     'RngPeresech.Interior.ColorIndex = 5
    ' rngTreug.Activate
'    rngTreug.Select
     'RngT.Activate
     'RngT.Select
     'RngPeresech.Activate
     'RngPeresech.Select
            '
     'If Not RngPeresech Is Nothing Then
         'RngPeresech.Interior.ColorIndex = 5
     'End If
     'RngPeresech = nil
     'N = N + 1
'Next

End Sub

[/vba]

Gustav, [vba]

Код

Private Sub CommandButton1_Click()
Dim NomCol As Integer
Dim DlRebra As Integer
Dim NadstrH As Integer
Dim RecCount As Integer
Dim a As Integer

'Sheet.Unprotect
Application.ScreenUpdating = False

RecCount = Sheets("0").Range("B1")
'NomCol = TextBox1.Value
'DlRebra = TextBox2.Value
'VisNadstr = TextBox3.Value

NomCol = 4
DlRebra = 4
VisNadstr = 10

Dim rngTreug As Range, Rng1 As Range, rngBig, RngPeresech, RngT As Range

a = NomCol - DlRebra + 1
Set rngBig = Range(Cells(1, 4 * (a - 1) + 2).Address(False, False), Cells(RecCount - a + 1, 4 * a + 1).Address(False, False))
For a = NomCol - DlRebra + 1 + 1 To DlRebra
     Set Rng1 = Range(Cells(1, 4 * (a - 1) + 2).Address(False, False), Cells(RecCount - a + 1, 4 * a + 1).Address(False, False))
     Set rngBig = Union(Rng1, rngBig)
Next

a = NomCol - DlRebra + 1
Set rngTreug = Range(Cells(RecCount - DlRebra + 1, 4 * (a - 1) + 2).Address(False, False), Cells(RecCount - a + 1, 4 * a + 1).Address(False, False))
For a = NomCol - DlRebra + 1 + 1 To DlRebra
    Set Rng1 = Range(Cells(RecCount - DlRebra + 1, 4 * (a - 1) + 2).Address(False, False), Cells(RecCount - a + 1, 4 * a + 1).Address(False, False))
    Set rngTreug = Union(Rng1, rngTreug)
Next

rngBig.Interior.ColorIndex = 6
rngTreug.Interior.ColorIndex = 4

Dim N As Double
Dim K As Integer
Dim S1 As Integer
Dim S2 As Integer
N = 0

'Set Rng1 = Intersect(rngBig, rngTreug)
'Rng1.Interior.ColorIndex = 5

'For K = 2 To RecCount
  '   Set RngT = rngTreug.Offset(2 - K, 0)
   '  Set RngPeresech = Intersect(RngT, rngTreug)

     'RngT.Interior.ColorIndex = 5
     'RngPeresech.Interior.ColorIndex = 5
    ' rngTreug.Activate
'    rngTreug.Select
     'RngT.Activate
     'RngT.Select
     'RngPeresech.Activate
     'RngPeresech.Select
            '
     'If Not RngPeresech Is Nothing Then
         'RngPeresech.Interior.ColorIndex = 5
     'End If
     'RngPeresech = nil
     'N = N + 1
'Next

End Sub

Ответить

СообщениеGustav, [vba]

Код

Private Sub CommandButton1_Click()
Dim NomCol As Integer
Dim DlRebra As Integer
Dim NadstrH As Integer
Dim RecCount As Integer
Dim a As Integer

'Sheet.Unprotect
Application.ScreenUpdating = False

RecCount = Sheets("0").Range("B1")
'NomCol = TextBox1.Value
'DlRebra = TextBox2.Value
'VisNadstr = TextBox3.Value

NomCol = 4
DlRebra = 4
VisNadstr = 10

Dim rngTreug As Range, Rng1 As Range, rngBig, RngPeresech, RngT As Range

a = NomCol - DlRebra + 1
Set rngBig = Range(Cells(1, 4 * (a - 1) + 2).Address(False, False), Cells(RecCount - a + 1, 4 * a + 1).Address(False, False))
For a = NomCol - DlRebra + 1 + 1 To DlRebra
     Set Rng1 = Range(Cells(1, 4 * (a - 1) + 2).Address(False, False), Cells(RecCount - a + 1, 4 * a + 1).Address(False, False))
     Set rngBig = Union(Rng1, rngBig)
Next

a = NomCol - DlRebra + 1
Set rngTreug = Range(Cells(RecCount - DlRebra + 1, 4 * (a - 1) + 2).Address(False, False), Cells(RecCount - a + 1, 4 * a + 1).Address(False, False))
For a = NomCol - DlRebra + 1 + 1 To DlRebra
    Set Rng1 = Range(Cells(RecCount - DlRebra + 1, 4 * (a - 1) + 2).Address(False, False), Cells(RecCount - a + 1, 4 * a + 1).Address(False, False))
    Set rngTreug = Union(Rng1, rngTreug)
Next

rngBig.Interior.ColorIndex = 6
rngTreug.Interior.ColorIndex = 4

Dim N As Double
Dim K As Integer
Dim S1 As Integer
Dim S2 As Integer
N = 0

'Set Rng1 = Intersect(rngBig, rngTreug)
'Rng1.Interior.ColorIndex = 5

'For K = 2 To RecCount
  '   Set RngT = rngTreug.Offset(2 - K, 0)
   '  Set RngPeresech = Intersect(RngT, rngTreug)

     'RngT.Interior.ColorIndex = 5
     'RngPeresech.Interior.ColorIndex = 5
    ' rngTreug.Activate
'    rngTreug.Select
     'RngT.Activate
     'RngT.Select
     'RngPeresech.Activate
     'RngPeresech.Select
            '
     'If Not RngPeresech Is Nothing Then
         'RngPeresech.Interior.ColorIndex = 5
     'End If
     'RngPeresech = nil
     'N = N + 1
'Next

End Sub

[/vba]

Автор - Chelius
Дата добавления - 16.03.2013 в 20:53

Дата: Суббота, 16.03.2013, 20:55 | Сообщение № 4

Группа: Пользователи

Ранг: Новичок

Сообщений: 15

Репутация: 0 ±

Замечаний: 0% ±

я файлик прикрепил

Ответить

Дата: Суббота, 16.03.2013, 20:57 | Сообщение № 5

Группа: Друзья

Ранг: Старожил

Сообщений: 2012

Репутация: 373 ±

Замечаний: 0% ±

Excel2016

Цитата (Chelius)

я файлик прикрепил

Точно? а куда - может не к тому поезду?

Ответить

Дата: Суббота, 16.03.2013, 21:08 | Сообщение № 6

Группа: Пользователи

Ранг: Новичок

Сообщений: 15

Репутация: 0 ±

Замечаний: 0% ±

очень жаль что максимум 100 кб
http://us.ua/1066038/ - это ссылочка на файл
Суть в том чтобы найти все регионы равные региону треугольника(в конце зеленым) среди столбца(большой регион, выделен желтым)
найти и выделить

Ответить

Дата: Суббота, 16.03.2013, 21:13 | Сообщение № 7

Группа: Пользователи

Ранг: Новичок

Сообщений: 15

Репутация: 0 ±

Замечаний: 0% ±

Gustav, уверен. опытные разработчики такую задачу решают без труда. только вот найти ее решение для меня затруднительно

Ответить

Дата: Суббота, 16.03.2013, 21:21 | Сообщение № 8

Группа: Пользователи

Ранг: Новичок

Сообщений: 15

Репутация: 0 ±

Замечаний: 0% ±

Michael_S, можно решить задачу не оптимально - сдвигать относительно треугольника
[vba]

Код

For K = 2 To RecCount
Set RngT = rngTreug.Offset(2 - K, 0) 'пробегаем по всему большому диапазону в поиске диапазона подобных треугольнику
NEXT K

[/vba]
А затем сравнивать диапазон RngT и rngTreug. Тогда вопрос как сравнить значения диапазона? Неужели пробегаться по каждой ячейке и сравнивать? уверен есть более рациональные и практичные способы сравнить ззначения соразмерных диапазонов, ведь не тупые люди писали библиотеку для вба!

Ответить

Дата: Суббота, 16.03.2013, 21:35 | Сообщение № 9

Группа: Пользователи

Ранг: Новичок

Сообщений: 15

Репутация: 0 ±

Замечаний: 0% ±

Молчание - знак непонимания. Постановка вопроса понятна? Может мне переформулировать что-либо или уточнить?

Сообщение отредактировал Chelius - Суббота, 16.03.2013, 21:36

Ответить

Дата: Суббота, 16.03.2013, 21:39 | Сообщение № 10

Группа: Пользователи

Ранг: Новичок

Сообщений: 15

Репутация: 0 ±

Замечаний: 0% ±

Gustav, спасибо за книгу. Не могу найти то, что нужно. Наверняка, там есть, но мой английский ограничивает уровень понимания описанных там вещей

Ответить

Дата: Суббота, 16.03.2013, 21:44 | Сообщение № 11

Группа: Друзья

Ранг: Участник клуба

Сообщений: 4513

Репутация: 1128 ±

Замечаний: 0% ±

Excel 2003

Файлик бы поменьше, а то посмотреть не получается.
Посмотрите, может это вам надо?

К сообщению приложен файл: Intersect_new.xls (36.5 Kb)

Номер мобильного модема (без голосовой связи)
9269171249 МегаФон, Московский регион.

Ответить

Дата: Суббота, 16.03.2013, 22:10 | Сообщение № 12

Группа: Пользователи

Ранг: Новичок

Сообщений: 15

Репутация: 0 ±

Замечаний: 0% ±

AlexM, спасибо но не то. Ваша постановка задачи решается строчкой
[vba]

Код

Set Range3 = Intersect(Range1, Range2)

[/vba]
мне же нужно найти все Range1 в Range2. Range1 совпадает с частью одинаковой размерности(которую нада выделить) в Range2 только по одинаковому набору значений

Ответить

Дата: Суббота, 16.03.2013, 22:21 | Сообщение № 13

Группа: Пользователи

Ранг: Новичок

Сообщений: 15

Репутация: 0 ±

Замечаний: 0% ±

AlexM, по аналогии с поиском ячеек в регионе. Но для региона почему то такая функция выдает ошибку
[vba]

Код

Set Rng1 = Rng2.FindNext(Rng3)

[/vba]

Ответить

Дата: Суббота, 16.03.2013, 22:25 | Сообщение № 14

Группа: Пользователи

Ранг: Новичок

Сообщений: 15

Репутация: 0 ±

Замечаний: 0% ±

если такой возможности не предусмотрено предлагаю дружно проклянуть разработчиков офиса

Ответить

Дата: Суббота, 16.03.2013, 23:43 | Сообщение № 15

Группа: Друзья

Ранг: Старожил

Сообщений: 1906

Репутация: 504 ±

Замечаний: 0% ±

Excel 2003, 2010

Цитата (Chelius)

предлагаю дружно проклянуть разработчиков офиса

а также надуть губы, забрать свои игрушки и перейти на счёты и арифмометры.

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

[offtop]ппс. ну не издевайтесь вы над русским языком до такой степени! нет слова "проклянуть". есть "проклясть".[/offtop]

помощь по Excel и VBA
ikki@fxmail.ru, icq 592842413, skype alex.ikki

Ответить

Дата: Суббота, 16.03.2013, 23:58 | Сообщение № 16

Группа: Пользователи

Ранг: Новичок

Сообщений: 15

Репутация: 0 ±

Замечаний: 0% ±

Цитата (ikki)

а также надуть губы, забрать свои игрушки и перейти на счёты и арифмометры.

это конечно шутка.

Цитата (ikki)

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

какой Вы *** принципиальный! вам не вериться и не понимается! я третий день пишу макрос потому что с вба раньше не работал и если бы мне было приблизительно было понятно как закодить эту часть алгоритма я бы вообще на форуме не регился дабы не знать Ваших 3 мегабайтовых принципов. Вы меня более обрадуете, если не будете писать подобные неконструктивные и не по делу сообщения вообще

Ответить

Дата: Воскресенье, 17.03.2013, 00:05 | Сообщение № 17

Группа: Друзья

Ранг: Старожил

Сообщений: 1906

Репутация: 504 ±

Замечаний: 0% ±

Excel 2003, 2010

ну так мне ж интересно - что за ерунду вы придумали, что вас никто понять не может? biggrin

biggrin

как я понимаю, ваш файл никому ещё не помог.
а звёздочки писать и язык коверкать - много ума не надо.

Цитата (Chelius)

Вы меня более обрадуете

ваша радость мне глубоко фиолетова. уж извините, еслечо.

не тратьте силы на звёздочки.
это не поможет.

попробуйте вместо этого сформулировать задачу - внятно и понятно.
на русском языке.
и проиллюстрировать небольшим примером.

я верю - вы сможете.

помощь по Excel и VBA
ikki@fxmail.ru, icq 592842413, skype alex.ikki

Ответить

Дата: Воскресенье, 17.03.2013, 10:16 | Сообщение № 18

Группа: Друзья

Ранг: Старожил

Сообщений: 2012

Репутация: 373 ±

Замечаний: 0% ±

Excel2016

Несмотря на вес файла (почти 4 м) посмотрел... в глазах зарябило, что-куда-зачем не понял...
Суть задачи и конечная цель непонятны, а потому и предложить что-то не могу. Попробуйте изложить по-проще и в файле по-меньше. Уверен, что суть можно вместить на один лист размером не более 100 кБ (в крайнем случае есть архиваторы).

Ответить

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Множественное вхождение регионов(range)

Страница 1 из 1
1

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