Здравствуйте Уважаемые коллеги! Который день ищу idMSO для элемента (button? tab? dialog?) Backstage - "Получить надстройки". Вот этот XML-код, скрывает все элементы Backstage, кроме злополучных надстроек (версия Excel 2021 x64)
Набрел в поисках на хороший РЕСУРС, перепробовал практически все, похожее на AddIns, но безуспешно. Может кто-то решал подобное? Или другим способом можно скрыть эту кнопку? Спасибо
Добрый день Уважаемые коллеги! Заметил, что не отображаются пользователи в некоторых разделах на форумах. В частности: в разделе "Сейчас на форуме" и в разделе "Читают тему" Проверял в Google Chrome, Opera и Edge. Все браузеры последних версий. Windows 11. Спасибо
Согласие есть продукт при полном непротивлении сторон
По мотивам ЭТОЙ темы. Здравствуйте Уважаемые! Давно хотел уточнить у Вас, дорогие друзья, такой вопрос. Есть Словарь элементами которого являются Массивы Как (и можно ли в принципе), напрямую, без передачи Массива в переменную, изменить какое нибудь его значение? Прочитать единичное значение напрямую получается, а вот изменить никак. Макрос складывает отдельные значения по ключу. Может где-то в синтаксисе туплю...
Код
Private Sub CommandButton1_Click()
Dim x(), iArr(), newArr(), I&, J&
x = Range("A1:F4").Value
On Error Resume Next
With CreateObject("Scripting.Dictionary")
For I = 1 To UBound(x)
.Add x(I, 1), Application.Index(x, I, 0)
If Err <> 0 Then
'так работает
iArr = .Item(x(I, 1))
For J = 2 To UBound(iArr)
iArr(J) = iArr(J) + x(I, J)
Next
.Item(x(I, 1)) = iArr
' 'необходимо увеличить каждый элемент массива на определенное значение
' 'прямое изменение элемента массива не работает
' For J = 2 To UBound(.Item(x(I, 1)))
' .Item(x(I, 1))(J) = .Item(x(I, 1))(J) + x(I, J)
' Next
Err.Clear
End If
Next
ReDim newArr(1 To .Count, 0 To UBound(x, 2)): I = Empty
For Each iKey In .Keys
I = I + 1: newArr(I, 0) = I
'простое обращение к элементу массива работает
For J = 1 To UBound(.Item(iKey))
newArr(I, J) = .Item(iKey)(J)
Next
Next
End With
Range("A16").Resize(UBound(newArr), UBound(newArr, 2) + 1) = newArr
End Sub
Согласие есть продукт при полном непротивлении сторон
Доброго времени суток, коллеги. Существует ли возможность изменения названия Темы (или, хот-бы, добавление примечания/тэга) в Избранном? Не всегда название Темы, данное ей ТС при создании, отражает то решение, которое мне показалось интересным. Спасибо
Согласие есть продукт при полном непротивлении сторон
Доброго всем утра! Решил более плотно попользовать MS Edge и столкнулся с проблемой указанной в описании темы. Не зависимо от раскладки клавиатуры (РУС/ЛАТ) кирилица не хочет копироваться в тело сообщения на форуме. Причем совсем не так, как например в Chrom'е. Это сообщение набираю в Chrom'е Примеры Браузер Chrome Версия 67.0.3396.87 (Официальная сборка), (64 бит) Раскладка РУС
Код
Sub Test()
'Русский язык, кирилица
'браузер Chrome Версия 67.0.3396.87 (Официальная сборка), (64 бит)
End Sub
Раскладка ENG
Код
Sub Test()
'Ðóññêèé ÿçûê, êèðèëèöà
'áðàóçåð Chrome Âåðñèÿ 67.0.3396.87 (Îôèöèàëüíàÿ ñáîðêà), (64 áèò)
End Sub
Браузер Microsoft Edge 42.17134.1.0 Раскладка РУС
Код
Sub Test()
'??????? ????, ????????
'??????? Chrome ?????? 67.0.3396.87 (??????????? ??????), (64 ???)
End Sub
Раскладка ENG
Код
Sub Test()
'??????? ????, ????????
'??????? Chrome ?????? 67.0.3396.87 (??????????? ??????), (64 ???)
End Sub
Обратите внимание, что в Chrom, при раскладке ENG, вместо кирилицы копируются какие-то 'иероглифы', а в Edge вопросительные знаки. Причем не зависимо от раскладки. В чем причина? Как победить? P.S. Могу ошибаться, но где то мелькало, что Михаил (БМВ) использует MS Edge
Согласие есть продукт при полном непротивлении сторон
Здравствуйте коллеги! В приложенном файле, в диапазоне 'DAYS', 12 несмежных областей. Как определить номер области, в которую попадает, допустим, активная ячейка, без перебора областей, коллекции Areas, этого диапазона? Код с определением номера в цикле
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("DAYS")) Is Nothing And Target.Count = 1 Then
On Error Resume Next
For I = 1 To Range("DAYS").Areas.Count
If Not Intersect(Target, Range("DAYS").Areas(I)) Is Nothing Then
iMonth = I
Select Case I
Case 1, 3, 5, 7, 8, 10, 12
eDay = 31
Case 4, 6, 9, 11
eDay = 30
Case 2
eDay = 28 'для високосного года исправить на 29
End Select
Exit For
End If
Next
Application.ScreenUpdating = False
Application.EnableEvents = False
If Target >= 1 And Target <= eDay Then
Target = DateSerial(2018, iMonth, Target)
Target.NumberFormat = "dd; @"
Else
MsgBox "Неверная дата!", vbCritical + vbOKOnly, "Ошибка"
Target = Empty
GoTo ExitSub
End If
End If
ExitSub:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Доброго времени суток, Уважаемые! Заметил, что в некоторых статьях раздела Приёмы (например), код расположен в одну строку, и, соответственно, при его копировании с сайта он так же вставляется в модуль одной строкой. Приходится его вручную разносить по строкам Это только у меня так? Можно ли это поправить? Спасибо
Доброго всем времени суток! Вчера столкнулся с таким феноменом. При заполнении ListBox'а на форме массивом данных, при наличии в массиве только ОДНОЙ строки, данные по столбцам не раскидываются, а собираются в один столбец. Из положения вышел при помощи 'костыля' с проверкой на количество строк и добавлением еще одной строки с пустыми значениями. Проверить можно вкл/откл 'костыль' и выбрав Исполнитель: Шкурина, Квартал: IV В чем причина? Где я туплю?
Скрытый текст
Код
Sub FindData(cmb1$, cmb2$)
Dim arrData(), arrList()
With Worksheets("Лист1")
arrData = .Range("D4:I" & .Cells(.Rows.Count, "D").End(xlUp).Row).Value
End With
For I = 1 To UBound(arrData)
If arrData(I, 6) = cmb1 And arrData(I, 1) = cmb2 Then
ReDim Preserve arrList(5, N)
arrList(0, N) = arrData(I, 6)
arrList(1, N) = arrData(I, 1)
arrList(2, N) = IIf(arrData(I, 2) = 0, "Нет", "Да")
arrList(3, N) = IIf(arrData(I, 4) = 0, "Нет", "Да")
arrList(4, N) = IIf(arrData(I, 5) = 0, "Нет", "Да")
arrList(5, N) = IIf(arrData(I, 3) = 0, "Нет", "Да")
N = N + 1
End If
Next
Me.ListBox1.Clear
If (Not Not arrList) <> 0 Then
'----костыль----
If UBound(arrList, 2) = 0 Then
ReDim Preserve arrList(5, 1)
For I = 0 To 5
arrList(I, 1) = Empty
Next
End If
'---------------
Me.ListBox1.List = Application.Transpose(arrList)
Else
MsgBox "Данные не найдены!", vbCritical + vbOKOnly
End If
End Sub
Согласие есть продукт при полном непротивлении сторон
Второй раз сутки вдруг перестают прокручиваться страницы сайта колесиком мыши. С остальными сайтами и локальными страницами проблем нет. Закономерность пока не заметил, после чего отваливается колесико, не понятно. Обновление страниц не помогает, только перезапуск всего браузера (Chrome 57.0.2987.98 (64-bit))
Поймал. Если в момент обновления любой страницы сайта крутануть колесико, то по окончании обновления колесико не работает
Доброго времени суток, ДрУги во программировании на VBA! Второй день бьюсь с проблемой программного изменения шрифта (название, полужирность и проч.) в ЧАСТИ текста колонтитула Наш друг пишичитай макрорекордер, кроме всего прочего, дает такой код
Код
Sub Макрос3() 'записано макрорекордером
With ActiveSheet.PageSetup
.LeftHeader = "&""Arial,полужирный""СТР:&""-,обычный"" &D &T"
.CenterHeader = "&""Arial,полужирный""СТРАНА:&""-,обычный"" Россия &""Arial,полужирный""РЕГИОН: &""-,обычный""Москва"
.RightHeader = "&""Arial,полужирный""САЙТ:&""-,обычный"" WWW.MOS.GOV"
End With
End Sub
так вот в этой заготовке никак не могу заменить некоторые слова на переменные
Код
Sub PreKolon2()
Country$ = "Россия"
City$ = "Москва"
Site$ = "WWW.MOS.GOV"
With ActiveSheet.PageSetup
.LeftHeader = "&""Arial,полужирный""СТР:&""-,обычный"" &D &T" 'Дата и Время
'слова Россия, Москва заменить переменными Country, Сity
.CenterHeader = "&""Arial,полужирный""СТРАНА:&""-,обычный"" Россия &""Arial,полужирный""РЕГИОН: &""-,обычный""Москва"
'WWW.MOS.GOV заменить на Site
.RightHeader = "&""Arial,полужирный""САЙТ:&""-,обычный"" WWW.MOS.GOV"
End With
ActiveSheet.PrintPreview
End Sub
Т.к. апмперсанд (&), кроме того, что он оператор объединения строк, в колонтитулах он еще и управляющий символ (см. строку с Датой и Временем) Никак не могу правильно расставить эти амперсанды с кавычками. В файле два листа. Первый - колонтитулы выставлены и оформлены вручную, второй - нужно так-же сделать программно, через переменные Спасибо.
Согласие есть продукт при полном непротивлении сторон
Добрый всем вечер. В этой теме соорудил UDF, которую нужно вводить как формулу массива. Соответственно размер диапазона, куда она вводится, заранее не известен и, при включении в него "лишних" ячеек в них появляется #Н/Д. Как с этим бороться? Штатные ЕСЛИОШИБКА(), связка ЕСЛИ() и всяких ЕНД() не работают. Условное форматирование НЕ предлагать. Спасибо
Код
Function UNIQUE(rng As Range) As Variant
Dim tmpArray()
Dim tmpCol As New Collection
On Error Resume Next
tmpArray = rng.Value
For I = LBound(tmpArray, 1) To UBound(tmpArray, 1)
For J = 1 To rng.Columns.Count
tmpCol.Add tmpArray(I, J), CStr(tmpArray(I, J))
Next
Next
ReDim tmpArray(tmpCol.Count - 1, 1)
For I = 0 To tmpCol.Count - 1
tmpArray(I, 0) = tmpCol(I + 1)
Next
UNIQUE = tmpArray
End Function
Согласие есть продукт при полном непротивлении сторон
Добрый день, коллеги. Давно мучает вопрос упрощения использования операторов сравнения в UDF (и не только) Например, когда нужно использовать оператор в критерии отбора. Видел как Дмитрий (The_Prist) вышел из подобной ситуации Смотрю в сторону Application.Evaluate, но...то ли лыжи не едут При пошаговом проходе по второй функции, отслеживая Application.Evaluate("If(" & rng2.Parent.Cells(cl.Row, rng2.Column) & kr & ")"), в Watches, вообще непоняные мне значения (числовое значение критерия умноженное на 100, иногда True). Надеялся, что будут True/False Ниже код UDF с жестко прописанным оператором и попытка ее унифицировать. И файл-пример их использования Натокните на мысли. Или развейте надежды Спасибо
Скрытый текст
Код
Function СЧЁТУНИКЕСЛИ(rng1 As Range, rng2 As Range, kr As Variant) As Double
'аргументы:
'rng1 - диапазон отбора уникальных значений, обязательный
'rng2 - диапазон условий, обязательный
'kr - условие (критерий), обязательный
On Error Resume Next
With New Collection
For Each cl In rng1
If rng2.Parent.Cells(cl.Row, rng2.Column) > kr Then 'жесткий вариант
.Add cl, CStr(cl)
If Err = 0 Then
СЧЁТУНИКЕСЛИ = СЧЁТУНИКЕСЛИ + 1
Else
Err.Clear
End If
End If
Next
End With
End Function
Function СЧЁТУНИКЕСЛИ_(rng1 As Range, rng2 As Range, kr As Variant) As Double
'аргументы:
'rng1 - диапазон отбора уникальных значений, обязательный
'rng2 - диапазон условий, обязательный
'kr - условие (критерий), обязательный
On Error Resume Next
With New Collection
For Each cl In rng1
If Application.Evaluate("If(" & rng2.Parent.Cells(cl.Row, rng2.Column) & kr & ")") Then 'попытка унифицировать
.Add cl, CStr(cl)
If Err = 0 Then
СЧЁТУНИКЕСЛИ_ = СЧЁТУНИКЕСЛИ_ + 1
Else
Err.Clear
End If
End If
Next
End With
End Function
Согласие есть продукт при полном непротивлении сторон
Вчера в ЭТОЙ теме психанул и позволил себе ответить ТС ссылкой на один, узкоспециализированный ресурс. Оправданий себе не ищу 1. Приношу извинения пользователю Forcer 2. Приношу извинения всему Уважаемому сообществу 3. Т.к. тема закрыта, прошу модераторов удалить злополучную ссылку 4. Готов понести справедливое наказание
З.Ы. Forcer, я не сомневаюсь что Вы опытный участник различных форумов, создайте тему, соответствующую Правилам ЭТОГО форума, и помощь не заставит себя ждать. Еще раз извините.
Согласие есть продукт при полном непротивлении сторон
Присваивание значений необязательным аргументам пользовательской функции (UDF) в коде самой функции, как массово присвоить значение необязательным аргументам
Добрый вечер, коллеги! При решении вопроса в ЭТОЙ теме написал UDF, которая подсчитывает количество уникальных значений по двум условиям. У Автора той темы возник вопрос об увеличении количества условий поиска уникальных. В процессе доработки возник вопрос : Как присвоить необязательным аргумента значения по умолчанию, НО не константы?
Объявление функции таким способом Function СЧЁТУНИКЕСЛИМН(rngU As Range, _ rng1 As Range, kr1 As Variant, Optional rng2 As Range = rng1, Optional kr2 As Variant = kr1, .........) конечно же привел к ошибке.
Доработал функцию таким методом, но, мне кажется, есть какой-то другой способ. Или мне действительно кажется? Как быть при действительно большом количестве однотипных необязательных аргументов? Спасибо
Скрытый текст
Код
Function СЧЁТУНИКЕСЛИМН(rngU As Range, _
rng1 As Range, kr1 As Variant, _
Optional rng2 As Range, Optional kr2 As Variant, _
Optional rng3 As Range, Optional kr3 As Variant, _
Optional rng4 As Range, Optional kr4 As Variant, _
Optional rng5 As Range, Optional kr5 As Variant) As Double
'аргументы:
'rngU - диапазон отбора уникальных значений, обязательный
'rng1 - диапазон условий 1, обязательный
'kr1 - условие 1, обязательный
'rng2 - диапазон условий 1, необязательный
'kr2 - условие 1, необязательный
'и т.д. до 5-ти условий
'определение необязательных аргументов, если они не заданы
If rng2 Is Nothing Then
Set rng2 = rng1
kr2 = kr1
End If
If rng3 Is Nothing Then
Set rng3 = rng1
kr3 = kr1
End If
If rng4 Is Nothing Then
Set rng4 = rng1
kr4 = kr1
End If
If rng5 Is Nothing Then
Set rng5 = rng1
kr5 = kr1
End If
Dim cl As Range
СЧЁТУНИКЕСЛИМН = 0
On Error Resume Next
With New Collection
For Each cl In rngU
If rng1.Parent.Cells(cl.Row, rng1.Column).Value Like kr1 And _
rng2.Parent.Cells(cl.Row, rng2.Column) Like kr2 And _
rng3.Parent.Cells(cl.Row, rng3.Column) Like kr3 And _
rng4.Parent.Cells(cl.Row, rng4.Column) Like kr4 And _
rng5.Parent.Cells(cl.Row, rng5.Column) Like kr5 Then
.Add cl, CStr(cl)
If Err = 0 Then
СЧЁТУНИКЕСЛИМН = СЧЁТУНИКЕСЛИМН + 1
Else
Err.Clear
End If
End If
Next
End With
End Function
Пишет какой-то Invalid... и указывает на первую фигурную скобку хотя в справке черным по английскому
Цитата
MATCH returns the position of the matched value within lookup_array, not the value itself. For example, MATCH("b",{"a","b","c"},0) returns 2, the relative position of "b" within the array {"a","b","c"}.
Формат ячейки ДДД не соответствует номеру дня недели, отображение дня недели (Пн, Вт и т.д.) после применения формата "ДДД" не соответствует его номеру (1,2 и т.д.)
формула, в которой каждый из двух блоков ИНДЕКС(..ПОИСКПОЗ...) возвращает значение соответствующей ячейки, НО их связка (через двоеточие) для ВПР является аргументом "таблица", в которой ВПР и ищет значение. Объясните неразумному логику формулы? Как такое может быть? Роль двоеточия? Мануалов, справок и поисков "скурил" достаточно. Сразу прошу меня простить ("прощенное воскресенье" все-таки ) Файл из вышеуказанной темы прилагаю Спасибо
Согласие есть продукт при полном непротивлении сторон
Sub fmtCDDEL()
Dim fmtCD As FormatCondition
On Error GoTo Err
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With Cells.FormatConditions
Ans = MsgBox("В Вашем файле " & .Count & " правил условного форматирования!" & Chr(13) & "Удалить их?", vbInformation + vbYesNo)
If Ans = vbNo Then Exit Sub
I = 1
Do While .Count <> 0
Cells.FormatConditions(I).Delete
Application.StatusBar = "Удаляется " & I & " правило. Пожалуйста подождите...."
DoEvents
I = I + 1
Loop
End With
Err:
With Application
If Cells.FormatConditions.Count <> 0 Then
.StatusBar = "Не удалено " & Cells.FormatConditions.Count & ", запустите макрос еще раз..."
Else
.StatusBar = False
End If
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
но без обработчика ошибок он удаляет РОВНО половину правил УФ и вылетает с ошибкой Subscript out of range. Приходится повторно его запускать, НО опять до удаления половины оставшихся правил УФ. И так пока все не удаляться. В чем причина? Файл не прикладываю - больно тяжел. Можно взять по ссылке в первом посте
Согласие есть продукт при полном непротивлении сторон
Вчера, при разборе этой темы, столкнулся со следующим: вот этот код
Код
Sub SaveText_2()
Dim SH As Object
I = 1
For Each SH In ActiveSheet.Shapes
With SH.OLEFormat.Object
If SH.Type <> msoTextBox Or .Text Like "*Внимание*" Then GoTo 10
Worksheets(2).Range("A" & I).Value = .Text
End With
I = I + 1
10 Next
End Sub
вылетает с ошибкой на строке If SH.Type<>....Or... Then...Код ошибки: Run-time error 438: Object doesn't support this property or method Если желаемое записать вот так:
Код
Sub SaveText_3()
Dim SH As Object
I = 1
For Each SH In ActiveSheet.Shapes
With SH.OLEFormat.Object
If SH.Type <> msoTextBox Then GoTo 10
If .Text Like "*Внимание*" Then GoTo 10
Worksheets(2).Range("A" & I).Value = .Text
End With
I = I + 1
10 Next
End Sub
все работает. В чем ошибка? Прилагаю файл с которым вчера "боролись"
Согласие есть продукт при полном непротивлении сторон
Помогите, чё-т туплю...(может уже в отпуск пора ) Нужно формулой посчитать количество сотрудников, у которых в квартале (полугодии) есть хотя-бы одна галка Спасибо
Согласие есть продукт при полном непротивлении сторон
Добрый вечер! Помогите разобраться в API (сам не силен, к сожалению). Вот это код:
Код
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Const GWL_STYLE As Long = (-16)
Private Const WS_SYSMENU As Long = &H80000
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_MAXIMIZEBOX As Long = &H10000
Private Sub UserForm_Initialize()
Dim lngFrmHndl As Long, lngStyle As Long
lngFrmHndl = FindWindow(vbNullString, Me.Caption)
lngStyle = GetWindowLong(lngFrmHndl, GWL_STYLE)
lngStyle = lngStyle Or WS_SYSMENU
lngStyle = lngStyle Or WS_MINIMIZEBOX
lngStyle = lngStyle Or WS_MAXIMIZEBOX
SetWindowLong lngFrmHndl, GWL_STYLE, (lngStyle)
DrawMenuBar lngFrmHndl
End Sub
добавляет на UserForm кнопки "Свернуть/Развернуть" и "Во весь экран". Что в нем нужно убрать (добавить?) что-бы осталась только "Свернуть/Развернуть" Спасибо!
Согласие есть продукт при полном непротивлении сторон
С вербным воскресеньицем всех! Помогите пожалуйста! Как отключить обработчик события контрола UserForm инициируемый из обработчика события другого контрола на этой-же форме? Что-то на подобии Application.EnableEvents для событий листа. Подскажите кто как выходит из положения?
З.Ы. Про применение глобальных переменных-флагов читал, но что-то не срабатывает
Согласие есть продукт при полном непротивлении сторон
которая из диапазона .Range("A1:B" & LastCol - 1) делает таблицу и применяет к ней стиль. Как программно преобразовать данный диапазон обратно в "диапазон" с сохранением стиля. Вручную получается, но макрорекордер ничего не записывает. Спасибо!
Согласие есть продукт при полном непротивлении сторон