Здравствуйте. Помогите пожалуйста усовершенствовать форму. В форме есть обязательные и необязательные поля. Обязательные поля отмечены восклицательным знаком (например). Форму должны заполнять разные люди. Хочется сделать счетчик при помощи VBA, какой процент обязательных полей уже заполнен и вывести рядом "персон", которые не заполнили еще свои обязательные поля. Пока счетчик я сделала при помощи формулы, но хочется избавится от всей этой лишней информации - "ок", "нок". К тому же при помощи формулы получается вывести только одного ответственного за пропущенные поля, а хотелось бы всех. Пример приложен. Буду премного благодарна.
Здравствуйте. Помогите пожалуйста усовершенствовать форму. В форме есть обязательные и необязательные поля. Обязательные поля отмечены восклицательным знаком (например). Форму должны заполнять разные люди. Хочется сделать счетчик при помощи VBA, какой процент обязательных полей уже заполнен и вывести рядом "персон", которые не заполнили еще свои обязательные поля. Пока счетчик я сделала при помощи формулы, но хочется избавится от всей этой лишней информации - "ок", "нок". К тому же при помощи формулы получается вывести только одного ответственного за пропущенные поля, а хотелось бы всех. Пример приложен. Буду премного благодарна.Tunka-s
YouGreed, спасибо большое. Если никто не поможет с макросом, буду использовать вашу формулу. Интересно, нет ответа по VBA, это потому что задача такая не интересная или потому что пятница...
YouGreed, спасибо большое. Если никто не поможет с макросом, буду использовать вашу формулу. Интересно, нет ответа по VBA, это потому что задача такая не интересная или потому что пятница...Tunka-s
Private Sub Worksheet_Change(ByVal Target As Range) lr = Cells(Rows.Count, 1).End(xlUp).Row If Not Intersect(Target, Range("a3:c" & lr)) Is Nothing Then Dim kolTotal&, kolOk& kolTotal = lr - 2 With CreateObject("Scripting.Dictionary"): .CompareMode = 1 For i = 3 To lr If Cells(i, 3) = "" And Cells(i, 4) = "!" Then If Trim(Cells(i, 1)) <> "" Then .Item(Trim(Cells(i, 1))) = .Item(Trim(Cells(i, 1))) + 1 Else kolOk = kolOk + 1 End If Next i Range("f2", [f2].End(xlDown)).ClearContents Range("f2:f" & .Count + 1) = Application.WorksheetFunction.Transpose(.keys) End With Range("e2") = kolOk / kolTotal End If End Sub
[/vba] % заполненных считала, как кол-во "ОК" разделить на общее кол-во полей, если не правильно, можете обратно на свою формулу поменять
Tunka-s, так подойдет? [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) lr = Cells(Rows.Count, 1).End(xlUp).Row If Not Intersect(Target, Range("a3:c" & lr)) Is Nothing Then Dim kolTotal&, kolOk& kolTotal = lr - 2 With CreateObject("Scripting.Dictionary"): .CompareMode = 1 For i = 3 To lr If Cells(i, 3) = "" And Cells(i, 4) = "!" Then If Trim(Cells(i, 1)) <> "" Then .Item(Trim(Cells(i, 1))) = .Item(Trim(Cells(i, 1))) + 1 Else kolOk = kolOk + 1 End If Next i Range("f2", [f2].End(xlDown)).ClearContents Range("f2:f" & .Count + 1) = Application.WorksheetFunction.Transpose(.keys) End With Range("e2") = kolOk / kolTotal End If End Sub
[/vba] % заполненных считала, как кол-во "ОК" разделить на общее кол-во полей, если не правильно, можете обратно на свою формулу поменятьManyasha
Roman777, .Count - считает кол-во ключей в словаре, прибавляем 1, т.к. вывод начинаем со 2-й строки, а не с 1-й. Transpose - это функция листа ТРАНСП(). Без транспонирования ключи буду выводиться в строчку, т.е. если мы напишем просто [vba]
Код
Range("f2:f" & .Count + 1) =.keys
[/vba] макрос выведет во все ячейки указанного диапазона только первый элемент полученного массива.
Roman777, .Count - считает кол-во ключей в словаре, прибавляем 1, т.к. вывод начинаем со 2-й строки, а не с 1-й. Transpose - это функция листа ТРАНСП(). Без транспонирования ключи буду выводиться в строчку, т.е. если мы напишем просто [vba]
Код
Range("f2:f" & .Count + 1) =.keys
[/vba] макрос выведет во все ячейки указанного диапазона только первый элемент полученного массива. Manyasha
Спустя неделю обнаружила проблему. Когда все все заполнили, вместо 100% и пустого списка "должников" появляется Run time error 13. Можно это исправить? Спасибо.
Спустя неделю обнаружила проблему. Когда все все заполнили, вместо 100% и пустого списка "должников" появляется Run time error 13. Можно это исправить? Спасибо.Tunka-s
If .Count <> 0 Then Range("f2:f" & .Count + 1) = Application.WorksheetFunction.Transpose(.keys)
а в [vba]
Код
If Trim(Cells(i, 1)) <> "" Then .Item(Trim(Cells(i, 1))) = .Item(Trim(Cells(i, 1))) + 1
[/vba] только сразу оговорочка... вообще код изначально предполагал, что значения в столбце 1 не повторяются... если у вас в столбце Е значения будут повторяться, то код надо будет весь переправлять...)
Tunka-s, у Вас значения задаются вовсе не в этой строке
If .Count <> 0 Then Range("f2:f" & .Count + 1) = Application.WorksheetFunction.Transpose(.keys)
а в [vba]
Код
If Trim(Cells(i, 1)) <> "" Then .Item(Trim(Cells(i, 1))) = .Item(Trim(Cells(i, 1))) + 1
[/vba] только сразу оговорочка... вообще код изначально предполагал, что значения в столбце 1 не повторяются... если у вас в столбце Е значения будут повторяться, то код надо будет весь переправлять...)Roman777
Ох, замечательно! Эту строку я вообще убрала, потому что в начальном написании кода, % заполнения никогда не равен нулю. Так что я сделала все "в лоб". Теперь даже не знаю что делать. А данные конечно повторяются! Они и в начальном примере повторялись.
А этот IF, он же закрывается и выборка "лентяев" идет уже вне цикла. Что-то я совсем запуталась. Как же тогда область задается в цикле? Или область задаетыса с "WITH"?
Ох, замечательно! Эту строку я вообще убрала, потому что в начальном написании кода, % заполнения никогда не равен нулю. Так что я сделала все "в лоб". Теперь даже не знаю что делать. А данные конечно повторяются! Они и в начальном примере повторялись.
А этот IF, он же закрывается и выборка "лентяев" идет уже вне цикла. Что-то я совсем запуталась. Как же тогда область задается в цикле? Или область задаетыса с "WITH"?Tunka-s
Сообщение отредактировал Tunka-s - Понедельник, 30.11.2015, 18:22
Таблица не поменялась по сути своей, она сдвинулась и добавились еще три столбца, но они не функциональны с точки зрения данной задачи. Я уже все цифры и буквы поменяла, проценты считаются отлично. Не выводятся должности только, потому что не могу задать столбец Е!
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) lr = Cells(Rows.Count, 2).End(xlUp).Row If Not Intersect(Target, Range("e8:g" & lr)) Is Nothing Then Dim kolTotal&, kolOk& 'kolTotal = lr - 7 With CreateObject("Scripting.Dictionary"): .CompareMode = 1 For i = 8 To lr
If Cells(i, 4) = "!" Then kolTotal = kolTotal + 1
End If 'If Cells(i, 7) = "" And Cells(i, 4) = "!" Then If Trim(Cells(i, 7)) <> "" Then '.Item(Trim(Cells(i, 7))) = .Item(Trim(Cells(i, 7))) + 1 'else kolOk = kolOk + 1 End If Next i Range("a2", [a2].End(xlDown)).ClearContents If .Count <> 0 Then Range("a2:a" & .Count + 1) = Application.WorksheetFunction.Transpose(Range(.keys)) End With ' Range("b2") = kolOk ' Range("c2") = kolTotal Range("b2") = kolOk / kolTotal End If End Sub
[/vba]
Таблица не поменялась по сути своей, она сдвинулась и добавились еще три столбца, но они не функциональны с точки зрения данной задачи. Я уже все цифры и буквы поменяла, проценты считаются отлично. Не выводятся должности только, потому что не могу задать столбец Е!
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) lr = Cells(Rows.Count, 2).End(xlUp).Row If Not Intersect(Target, Range("e8:g" & lr)) Is Nothing Then Dim kolTotal&, kolOk& 'kolTotal = lr - 7 With CreateObject("Scripting.Dictionary"): .CompareMode = 1 For i = 8 To lr
If Cells(i, 4) = "!" Then kolTotal = kolTotal + 1
End If 'If Cells(i, 7) = "" And Cells(i, 4) = "!" Then If Trim(Cells(i, 7)) <> "" Then '.Item(Trim(Cells(i, 7))) = .Item(Trim(Cells(i, 7))) + 1 'else kolOk = kolOk + 1 End If Next i Range("a2", [a2].End(xlDown)).ClearContents If .Count <> 0 Then Range("a2:a" & .Count + 1) = Application.WorksheetFunction.Transpose(Range(.keys)) End With ' Range("b2") = kolOk ' Range("c2") = kolTotal Range("b2") = kolOk / kolTotal End If End Sub
If Trim(Cells(i, 7)) <> "" Then '.Item(Trim(Cells(i, 7))) = .Item(Trim(Cells(i, 7))) + 1
[/vba]отвечают за заполнение массива для столбца А, ее не нужно убирать [p.s.]Если интересно, про словари тут можно почитать. Все очень доступно описано[/p.s.]
Tunka-s, проверяйте строчки [vba]
Код
If Trim(Cells(i, 7)) <> "" Then '.Item(Trim(Cells(i, 7))) = .Item(Trim(Cells(i, 7))) + 1
[/vba]отвечают за заполнение массива для столбца А, ее не нужно убирать [p.s.]Если интересно, про словари тут можно почитать. Все очень доступно описано[/p.s.]Manyasha
Все равно не понимаю, как считаются проценты у вас. lr - это количество строк, так? kolTotal = lr - 2, т.е. кол-во тотал, это не количество обязательных полей, а количество всех полей? Переношу ваш код в основной файл и опять у меня 33% при нулевом заполнении.
Все равно не понимаю, как считаются проценты у вас. lr - это количество строк, так? kolTotal = lr - 2, т.е. кол-во тотал, это не количество обязательных полей, а количество всех полей? Переношу ваш код в основной файл и опять у меня 33% при нулевом заполнении.Tunka-s