Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 21 След.
О погоде
 
Цитата
БМВ написал:
почки проклюнулись на яблонях
А в городе по дворам яблони уже цветут)
Формы. Как заполнять одну и ту же форму (ListBox) разными данными в зависимости от выделения
 
AAF, Дмитрий Щербаков, спасибо за наглядный пример) Значит зря я к ReDim Preserve массивы заранее создавал)

Как говорится: "Век живи, век учись... и дураком помрешь."
Формы. Как заполнять одну и ту же форму (ListBox) разными данными в зависимости от выделения
 
AAF, приветствую) Да нет проблемы. Был небольшой спор касательно ReDim Preserve без предварительного ReDim'а массива.
Посчитать для каждого группового ключа и даты нарастающую сумму
 
OlegO, Вы это для собственного развития пишите (код) или не знаете как применять листовые функции в VBA?)

Не гуру ни разу, но:
Если первое, то к сведению:
- пытаться на VBA соорудить более быстрый аналог встроенных или листовых функций - бесперспективное занятие, т.е. эти самые функции написаны на языках более низкого уровня и откомпилированы
- имеет смысл этих заниматься только для больших объемов данных (для массовой обработки)
- самое долгое касательно словарей - наполнение их данными, но это для больших объемов данных
- для поиска и индексации лучше писать свою процедуру на массивах вместо использования словарей, но это для больших объемов (поищите в сети проверенные алгоритмы поиска и попытайтесь воплотить их на VBA, во всяком случае это интересно)
- всяческие Split и Join тоже едят время будь здоров
Формы. Как заполнять одну и ту же форму (ListBox) разными данными в зависимости от выделения
 
Jack Famous, а ведь точно, с одномеркой и если нет Option Base такой вариант прокатывает. :) Но с двумерным и массивом прочей размерности такой финт ушами не пройдет.
Изменено: Anchoret - 12 Май 2018 09:21:38
Формы. Как заполнять одну и ту же форму (ListBox) разными данными в зависимости от выделения
 
Jack Famous, чтобы что-то Preserv'ить нужно это что-то инициировать - ReDim arrFill(0) перед циклом.
Пользовательская функция-аналог Hex (10-16) для больших чисел
 
Казанский, большое спасибо за интересный вариант! Похоже, что пора начать знакомство с WinAPI, а возможно и не только с ним)
Поиск совпадения по части с текста в ячейчках
 

Перекрестно сравниваем значение в двух ячейках. Если они равны , либо одна строка является подстрокой другой, то переменная ff=Tue

Код
if instr(1,[A],[B1],1) or instr(1,[B1],[A1],1) then ff=true
Выборка значений фильтра в макросе по "маске"
 
Офф:
Неужто первый контакт с иным разумом? И где тут координаты Вашей планеты?
Не работает событие, Не работает событие и вылезает ошибка
 
vikttur, да, но у ТС другое событие)
Кросс.
Не работает событие, Не работает событие и вылезает ошибка
 
telesh, конечно косячный... А где собственно проверка на диапазон, в котором произошли изменения? Это проверка должна быть перед циклом. При изменении содержимого ячеек на листе с обработчиком событий всегда нужно отключать эти события. У вас при любом изменении на листе запускается цикл изменений на этом-же листе , и т.к. события не отключены, то код уходит в рекурсию - снова и снова вызывается процедура обработки событий на листе пока стек не переполнится.
Перенос сожержимого определенной ячейки (по содержанию), перенос значения чейки
 
Задания раздают в разделе "Работа".
Выражения с Evaluate() - какие можно использовать символы?
 
Казанский, интересный способ заполнения массива. Взял на заметку) Спасибо.
Сортировка макросом по двум условиям
 
О вредном GoTo
 
Go To - наследие процедурных языков программирования) Ваш КЭП
Первый Бейсик с которым я имел дело,  на котором учился писать что-то отдаленно похожее на программы содержал всего один вид цикла For, и два вида переходов: Go To , Go Sub. Потом был Ассемблер, где тоже всего три варианта вызова/перехода: Jp (абсолютный), Jr (относительный) и Call. Далее лет 15 забвения всех поползновений в сторону программирования. И вдруг устраиваюсь в такое замечательное место, где есть САП (с которым раньше дел не имел, и которому прямо на рабочем месте меня обучал наш сапер аж целых полчаса) ,Excel и необходимость упорядочить хаос творившийся вокруг этими подручными средствами. Ну и понеслось. Разумеется GoTo встречается в моем коде довольно часто)
Удаление рисунка из под ячейки - только в том случае, если ячейка пуста или в ней - неключевое слово.
 
Ігор Гончаренко, спасибо за разъяснение!  
Файл excel сам изменил формат всех ячеек на всех листах книги на формат ДАТА
 
Цитата
Oleg dashenko написал:
И как вернуть все назад
Не знаю насколько это сработает в мультипользовательском файле - ПКМ на ярлыке файла, восстановить предыдущую версию, выбрать нужную.
Формы. Как заполнять одну и ту же форму (ListBox) разными данными в зависимости от выделения
 
Цитата
Jack Famous написал:
без примера не разберусь
Так там пример и есть) Экстраполируйте на любые другие элементы формы с учетом их особенностей.
Формы. Как заполнять одну и ту же форму (ListBox) разными данными в зависимости от выделения
 
Jack Famous,файл не смотрел, поэтому что там в диапазоне - без понятия. Да, и код не мой, а немного измененный Ваш)
Варианты заполнения:
- listbox1.list=arr , т.е. массивом
- циклом с Add.Item
- задать в качестве источника заполнения диапазон на листе

Лично я загружаю массивом.
Вариант пакетной обработки контролов:
Код
aa = Array(1, 2, 3, 4)
For a = 1 To 4
  Me.Controls("Label" & a).Caption = aa(a - 1)
Next
Поэтому удобнее их стандартизировать по названиям.
Формы. Как заполнять одну и ту же форму (ListBox) разными данными в зависимости от выделения
 
А вот так?
Код
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim rngGents As Range, rngLadies As Range
 
Set rngGents = [D3:F8]
Set rngLadies = [K5:M10]
 
If Not Intersect(Target, rngGents) Is Nothing Then: FormSearch.ListBoxItems.List = rngGents.value: FormSearch.Show
If Not Intersect(Target, rngLadies) Is Nothing Then: FormSearch.ListBoxItems.List = rngLadies.value: FormSearch.Show
End Sub

Хотя тут задается в качестве приемника вся коллекция листбоксов формы... Т.е. тоже будет ошибка.

Еще можно через Array задать список адресов диапазонов, и по этому списку загружать в листбоксы циклом.

Изменено: Anchoret - 4 Май 2018 20:20:01
Универсальный макрос для быстрого переключения между значениями фильтра за счет "горячих" клавиш
 
falmrom, макрос работает по столбцу с активной ячейкой. Была ошибка, а точнее не учтены вероятные пустые значения. Поэтому фильтр после встреченных пустых сразу возвращался в начало.
Вот обновленная версия (кнопки переназначены на новые макросы):
Код
Sub PrevFilter()'назад
Application.ScreenUpdating = False
SetAutoFilter -1
Application.ScreenUpdating = True
End Sub
'---------------
Sub NextFilter()'вперед
Application.ScreenUpdating = False
SetAutoFilter 1
Application.ScreenUpdating = True
End Sub
'---------------
Sub SetAutoFilter(ByVal z%)
Dim aa As Range, DC As Object, a&, b%, dt$, arr()
Set DC = CreateObject("Scripting.Dictionary")
Set aa = ActiveCell.CurrentRegion
b = ActiveCell.Column
arr = Intersect(aa, ActiveCell.EntireColumn).Value
For a = 2 To aa.Rows.Count
  If Not DC.exists(CStr(arr(a, 1))) Then DC.Add CStr(arr(a, 1)), DC.Count
Next
If DC.Count < 1 Then Exit Sub
arr = DC.keys()
If ActiveSheet.AutoFilterMode Then
  With ActiveSheet
    .AutoFilter.Range.Cells(1, b).Select
    If .AutoFilterMode Then
      If .AutoFilter.Filters(b).On Then
        dt = Replace(.AutoFilter.Filters(b).Criteria1, "=", "")
      End If
      aa.AutoFilter field:=b
      Select Case z
      Case Is > 0
        If DC.Item(dt) = UBound(arr) Then
          aa.AutoFilter field:=b, Criteria1:="=" & arr(1), Operator:=xlFilterValues
        Else: aa.AutoFilter field:=b, Criteria1:="=" & arr(DC.Item(dt) + 1), Operator:=xlFilterValues
        End If
      Case Else
        If DC.Item(dt) = LBound(arr) Then
          aa.AutoFilter field:=b, Criteria1:="=" & arr(UBound(arr)), Operator:=xlFilterValues
        Else: aa.AutoFilter field:=b, Criteria1:="=" & arr(DC.Item(dt) - 1), Operator:=xlFilterValues
        End If
      End Select
    End If
  End With
End If
End Sub
Изменено: Anchoret - 4 Май 2018 19:49:20
Универсальный макрос для быстрого переключения между значениями фильтра за счет "горячих" клавиш
 
falmrom, .... В какое право?
Универсальный макрос для быстрого переключения между значениями фильтра за счет "горячих" клавиш
 
falmrom, если по вашему примеру + комментарии перед самим макросом, то нет. Можно добавить отключение обновление экрана в начале, и включение в конце.
Подсчет ключевых слов в диапазоне ячеек
 
Ну и альтернатива:
Код
Sub UniSeparate()
Dim arr(), a&, b%, c%, txt$, ff$, DC As Object, x&
arr = Intersect(ActiveCell.EntireColumn, ActiveCell.CurrentRegion).Value
Set DC = CreateObject("Scripting.Dictionary")
For x = 1 To UBound(arr)
  txt = arr(x, 1): b = InStr(txt, "("): c = InStr(txt, ")")
  Do While b * c > 0
    Select Case b
    Case Is < c And b > 0
      ff = Mid$(txt, b + 1, c - b - 1): a = a + 1
      b = InStr(b + 1, txt, "("): c = InStr(c + 1, txt, ")")
      If Not DC.exists(ff) Then DC.Add ff, 1 Else DC.Item(ff) = DC.Item(ff) + 1
    Case Is > c And c > 0: c = InStr(c + 1, txt, ")")
    Case Else: Exit Do
    End Select
  Loop
Next
If a < 1 Then Exit Sub
ActiveCell.Offset(, 3).Resize(DC.Count, 2) = Application.Transpose(Array(DC.keys(), DC.items()))
End Sub
Работает по столбцу, в котором активная ячейка. Выгрузка на пару столбцов правее исходного.

П.С.: Хитрый вариант транспонирования взял из кода выше.
Изменено: Anchoret - 4 Май 2018 13:53:04
Поздравляем JayBhagavan с Днем Рождения!!!
 
Не знаком, но поздравляю)
Подсчет ключевых слов в диапазоне ячеек
 
Michael_777, пользовательская функция:
Код
Function fFind$(txt$)
Dim a%, b%, c%, aa1%(), aa2%(), ff$, DC As Object, arr()
a = 1: ReDim aa1(0): ReDim aa2(0)
Set DC = CreateObject("Scripting.Dictionary")
Do While InStr(a, txt, "(") 'считаем открывающие скобки
  ReDim Preserve aa1(b): a = InStr(a, txt, "(") + 1: aa1(b) = a - 1: b = b + 1
Loop
If b < 1 Then Exit Function
a = 1
Do While InStr(a, txt, ")") 'теперь закрывающие
  ReDim Preserve aa2(c): a = InStr(a, txt, ")") + 1: aa2(c) = a - 1: c = c + 1
Loop
If c < 1 Then Exit Function
a = 0
For b = 0 To UBound(aa1)
  For c = 0 To UBound(aa2)
    If aa1(b) < aa2(c) Then 'если позиция открывающей скобки раньше закрывающей
      ff = Mid$(txt, aa1(b) + 1, aa2(c) - aa1(b) - 1) 'извлекаем подстроку
      If Not DC.exists(ff) Then DC.Add ff, 1 Else DC.Item(ff) = DC.Item(ff) + 1 'наполняем словарь
      a = a + 1: Exit For
    End If
  Next
Next
If DC.Count < 1 Then Exit Function
arr = DC.keys(): ff = ""
'формируем итоговую строку, где через спец.символы возврата каретки расположены:
'- общее кол-во межскобочных подстрок
'- элемент 1
'- счетчик по элементу 1
'- и так далее
For b = 0 To UBound(arr)
  ff = ff & vbCrLf & arr(b) & vbCrLf & DC.Item(arr(b))
Next
fFind = a & ff
End Function
Изменено: Anchoret - 3 Май 2018 19:07:22
VBA - Sub прерывается до завершения без видимой причины
 
RazorBaze, понятнее не стало) Но все еще жива уверенность, что все это можно было сделать раз в двадцать компактнее.
VBA - Sub прерывается до завершения без видимой причины
 
RazorBaze, ReDim zArr(1 to zRngCount). Диапазоны шерстите на том-же листе, на котором стоит обработчик событий? Если да, то при включенных событиях ваш мега код будет вызван пару десятков раз, а потом Excel поймет, что вы накосячили и прервет работу обработчика. Собственно об этом писали выше.

П.С.: Если не секрет, то какие космические расчеты вы проводите?
Замена пробелов в ячейке, до определенного момента
 
Цитата
Novichok55 написал:
ненужных уже после разъединения нижних подчеркиваний
Это тех, что вы же просили проставить вместо пробелов?) Ок.
Замена пробелов в ячейке, до определенного момента
 
Novichok55, там мелкая ошибка была, исправил выше.
Блин, знал бы необходимый  конечный вариант сделал бы иначе. Вариант с корректировкой:
Код
Sub test()
Dim dt$, aa, arr(), a&, b%, c%, ff As Boolean
arr = [a1].CurrentRegion.Value
For a = 1 To UBound(arr)
  aa = Split(arr(a, 1), " "): dt = aa(0)
  For b = 1 To UBound(aa)
    ff = False
    For c = 1 To Len(aa(b))
      If Mid$(aa(b), c, 1) Like "#" Then ff = True: Exit For
    Next
    If Not ff Then dt = dt & "_" & aa(b) Else dt = dt & " " & aa(b)
  Next
  aa = Split(dt, " ")
  If UBound(arr, 2) < UBound(aa) + 1 Then ReDim Preserve arr(1 To UBound(arr), 1 To UBound(aa) + 1)
  For b = 0 To UBound(aa): arr(a, b + 1) = aa(b): Next
Next
[c1].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub
Изменено: Anchoret - 1 Май 2018 21:16:48
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 21 След.