Поразбирался сам и получилось но не совсем Вот такой макрос, но изменения ячеек считывается только при изменении в диапазоне 1 т.е. меняя что-то в диапазоне 2 ничего в выводе результата не меняется, но только затронув диапазон1, даже оставив в ячейках теже значения, все считывается и работает... Как сделать все процессы независимыми?
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim d As Object, arr, el, n&
If Intersect(Target, [диапазон1]) Is Nothing Then Exit Sub Set d = CreateObject("scripting.dictionary") d.CompareMode = 0 arr = [диапазон1].Value For Each el In arr If Not IsEmpty(el) Then d.Item(el) = d.Item(el) + 1 Next n = Application.Min(Rows.Count - [результат1].Rows(1).Row + 1, UBound(arr) * UBound(arr, 2)) Application.ScreenUpdating = False With [результат1].Resize(n, 2) .ClearContents .Columns(1).Resize(d.Count) = Application.Transpose(d.Keys) .Columns(2).Resize(d.Count) = Application.Transpose(d.Items) End With
Dim f As Object, arw, em, k& If Not Intersect(Target, [диапазон2]) Is Nothing Then Exit Sub Set f = CreateObject("scripting.dictionary") f.CompareMode = 0 arr = [диапазон2].Value For Each em In arw If Not IsEmpty(em) Then f.Item(em) = f.Item(em) + 1 Next k = Application.Min(Rows.Count - [результат2].Rows(1).Row + 1, UBound(arw) * UBound(arw, 2)) Application.ScreenUpdating = False With [результат2].Resize(k, 2) .ClearContents .Columns(1).Resize(f.Count) = Application.Transpose(f.Keys) .Columns(2).Resize(f.Count) = Application.Transpose(f.Items) End With
End Sub
[/vba]
Поразбирался сам и получилось но не совсем Вот такой макрос, но изменения ячеек считывается только при изменении в диапазоне 1 т.е. меняя что-то в диапазоне 2 ничего в выводе результата не меняется, но только затронув диапазон1, даже оставив в ячейках теже значения, все считывается и работает... Как сделать все процессы независимыми?
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim d As Object, arr, el, n&
If Intersect(Target, [диапазон1]) Is Nothing Then Exit Sub Set d = CreateObject("scripting.dictionary") d.CompareMode = 0 arr = [диапазон1].Value For Each el In arr If Not IsEmpty(el) Then d.Item(el) = d.Item(el) + 1 Next n = Application.Min(Rows.Count - [результат1].Rows(1).Row + 1, UBound(arr) * UBound(arr, 2)) Application.ScreenUpdating = False With [результат1].Resize(n, 2) .ClearContents .Columns(1).Resize(d.Count) = Application.Transpose(d.Keys) .Columns(2).Resize(d.Count) = Application.Transpose(d.Items) End With
Dim f As Object, arw, em, k& If Not Intersect(Target, [диапазон2]) Is Nothing Then Exit Sub Set f = CreateObject("scripting.dictionary") f.CompareMode = 0 arr = [диапазон2].Value For Each em In arw If Not IsEmpty(em) Then f.Item(em) = f.Item(em) + 1 Next k = Application.Min(Rows.Count - [результат2].Rows(1).Row + 1, UBound(arw) * UBound(arw, 2)) Application.ScreenUpdating = False With [результат2].Resize(k, 2) .ClearContents .Columns(1).Resize(f.Count) = Application.Transpose(f.Keys) .Columns(2).Resize(f.Count) = Application.Transpose(f.Items) End With
Самый простой способ (не значит, что самый правильный) If Intersect(Target, [диапазон1]) Is Nothing Then Goto A ... End With
A: Dim f As Object, arw, em, k& ...
Не сработало, при таком написании результат на изменения в диапазон1 реагирует 1 раз и всё. А по второму совсем без реакции Так же реакция на изменения в диапазон1 отображается при изменении диапазон2
Цитата (_Boroda_)
Самый простой способ (не значит, что самый правильный) If Intersect(Target, [диапазон1]) Is Nothing Then Goto A ... End With
A: Dim f As Object, arw, em, k& ...
Не сработало, при таком написании результат на изменения в диапазон1 реагирует 1 раз и всё. А по второму совсем без реакции Так же реакция на изменения в диапазон1 отображается при изменении диапазон2Vyacheslav
Сообщение отредактировал Vyacheslav - Вторник, 09.04.2013, 16:23
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub Dim arr, el, n&, rng As Range Select Case False Case Intersect(Target, [диапазон1]) Is Nothing arr = [диапазон1].Value: Set rng = Range("результат1") Case Intersect(Target, [диапазон2]) Is Nothing arr = [диапазон2].Value: Set rng = Range("результат2") Case Else: Exit Sub End Select With CreateObject("scripting.dictionary") For Each el In arr .Item(el) = .Item(el) + 1 Next ' n = Application.Min(Rows.Count - rng.Row + 1, UBound(arr) * UBound(arr, 2)) rng.ClearContents rng.Resize(.Count) = Application.Transpose(Array(.Keys, .items)) End With End Sub
[/vba] n - непонятно для чего
может как-то так [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub Dim arr, el, n&, rng As Range Select Case False Case Intersect(Target, [диапазон1]) Is Nothing arr = [диапазон1].Value: Set rng = Range("результат1") Case Intersect(Target, [диапазон2]) Is Nothing arr = [диапазон2].Value: Set rng = Range("результат2") Case Else: Exit Sub End Select With CreateObject("scripting.dictionary") For Each el In arr .Item(el) = .Item(el) + 1 Next ' n = Application.Min(Rows.Count - rng.Row + 1, UBound(arr) * UBound(arr, 2)) rng.ClearContents rng.Resize(.Count) = Application.Transpose(Array(.Keys, .items)) End With End Sub
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub Dim arr, el, n&, rng As Range Select Case False Case Intersect(Target, [диапазон1]) Is Nothing arr = [диапазон1].Value: Set rng = Range("результат1") Case Intersect(Target, [диапазон2]) Is Nothing arr = [диапазон2].Value: Set rng = Range("результат2") Case Else: Exit Sub End Select With CreateObject("scripting.dictionary") For Each el In arr .Item(el) = .Item(el) + 1 Next ' n = Application.Min(Rows.Count - rng.Row + 1, UBound(arr) * UBound(arr, 2)) rng.ClearContents rng.Resize(.Count) = Application.Transpose(Array(.Keys, .items)) End With End Sub
[/vba]
n - непонятно для чего
совсем не работает, ошибка на ...e: Set rng = Range("результат1")
Цитата (nilem)
может как-то так [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub Dim arr, el, n&, rng As Range Select Case False Case Intersect(Target, [диапазон1]) Is Nothing arr = [диапазон1].Value: Set rng = Range("результат1") Case Intersect(Target, [диапазон2]) Is Nothing arr = [диапазон2].Value: Set rng = Range("результат2") Case Else: Exit Sub End Select With CreateObject("scripting.dictionary") For Each el In arr .Item(el) = .Item(el) + 1 Next ' n = Application.Min(Rows.Count - rng.Row + 1, UBound(arr) * UBound(arr, 2)) rng.ClearContents rng.Resize(.Count) = Application.Transpose(Array(.Keys, .items)) End With End Sub
[/vba]
n - непонятно для чего
совсем не работает, ошибка на ...e: Set rng = Range("результат1")Vyacheslav
е сработало, при таком написании результат на изменения в диапазон1 реагирует 1 раз и всё. А по второму совсем без реакции Так же реакция на изменения в диапазон1 отображается при изменении диапазон2
Уберите слово not в строке [vba]
Код
If Not Intersect(Target, [диапазон2]) Is Nothing Then Exit Sub
[/vba] Не заметил я его сразу. И напишите Goto A, как я уже писал выше. У меня все работает.
Цитата (Vyacheslav)
ошибка на ...e: Set rng = Range("результат1")
Значит, у Вас в файле нет имени "Результат1" У меня макрос от nilem работает
Цитата (Vyacheslav)
е сработало, при таком написании результат на изменения в диапазон1 реагирует 1 раз и всё. А по второму совсем без реакции Так же реакция на изменения в диапазон1 отображается при изменении диапазон2
Уберите слово not в строке [vba]
Код
If Not Intersect(Target, [диапазон2]) Is Nothing Then Exit Sub
[/vba] Не заметил я его сразу. И напишите Goto A, как я уже писал выше. У меня все работает.
Цитата (Vyacheslav)
ошибка на ...e: Set rng = Range("результат1")
Значит, у Вас в файле нет имени "Результат1" У меня макрос от nilem работает_Boroda_
Там и модифицировать ничего особо не надо. Но непонятны начальные условия - как определяются диапазоны, и как запускается код. А все изменения касаются только этой части.
Там и модифицировать ничего особо не надо. Но непонятны начальные условия - как определяются диапазоны, и как запускается код. А все изменения касаются только этой части.RAN
Цитата (Vyacheslav писал(а)): Появился такой вопрос: возможно ли модифицировать код, чтобы можно было считывать информацию с двух и более диапазонов, но выводить один результат?
Заранее, Спасибо!
Кто-нибудь может помочь?! третий день бьюсь - не выходит =(((
Кто-нибудь! Ау!
Цитата (Vyacheslav)
Цитата (Vyacheslav писал(а)): Появился такой вопрос: возможно ли модифицировать код, чтобы можно было считывать информацию с двух и более диапазонов, но выводить один результат?
Заранее, Спасибо!
Кто-нибудь может помочь?! третий день бьюсь - не выходит =(((
Вариант формульного решения с доп. столбцом (можно и без поп. столбца, только формула увеличится в размере раза в три, и считать она будет медленнее)
Формула получилась нечувствительна к регистру К сообщению приложен файл: 1204082.xls(30Kb)
Господа, хотел сделать на основе этого решения аналогичный пример, но где диапазон находится в одном столбце, но не получилось, в чем проблема?? Что меняется в этом случае? [moder]Читаем Правила форума, создаём свою тему. Эта тема закрыта[/moder]
Вариант формульного решения с доп. столбцом (можно и без поп. столбца, только формула увеличится в размере раза в три, и считать она будет медленнее)
Формула получилась нечувствительна к регистру К сообщению приложен файл: 1204082.xls(30Kb)
Господа, хотел сделать на основе этого решения аналогичный пример, но где диапазон находится в одном столбце, но не получилось, в чем проблема?? Что меняется в этом случае? [moder]Читаем Правила форума, создаём свою тему. Эта тема закрыта[/moder]Volkofx
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
