Страницы: 1
RSS
Вывод через Msgbox (?) значений ячеек, которые соответствуют заданным критериям
 
Уважаемые форумчане, приветствую!
В очередной раз прошу помощи)

Есть таблица, в которой сотрудники персонально заполняют значения ячеек (предварительно внеся свои ФИО в первый столбец). Учитывая человеческий фактор, сотрудники могут внести некорректные данные в ячейки. В этой связи был написан макрос с условиями УФ, который эти некорректные данные подсвечивает красной заливкой. Условно, получается что-то похожее на файл во вложении (естественно, в оригинале кол-во строк и столбцов на порядок больше).

Очень хотелось бы, чтобы при запуске макроса выводилось окно сообщения в котором отражалось, что, например, Федя имеет красные ячейки в столбце "название столбца", Петя имеет в другом столбце... и так поименный список. Совсем круто, если будут указаны номера строк.
Это реальная задача?

Заранее большое спасибо за участие!
 
Код
Sub LookRed()
    Dim y As Long
    y = Cells(Rows.Count, 1).End(xlUp).Row
    Dim r As Range
    Set r = Range(Cells(1, 1), Cells(y, 4))
    Dim x As Integer
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim dum As Object
    For y = 2 To r.Rows.Count
    For x = 2 To r.Columns.Count
        Select Case Cells(y, x).Interior.Color
        Case 255
            If Not dic.Exists(Cells(y, 1).Value) Then
            Set dic.Item(Cells(y, 1).Value) = CreateObject("Scripting.Dictionary")
            End If
            Set dum = dic.Item(Cells(y, 1).Value)
            dum.Item(y) = 0
            Set dic.Item(Cells(y, 1).Value) = dum
        End Select
    Next
    Next
    
    OutDic dic
End Sub
Sub OutDic(dic As Object)
    Dim vasya As Variant
    Dim s As String
    For Each vasya In dic.keys
        s = s & vasya & " имеет красные ячейки в строках " & Join(dic.Item(vasya).keys(), ", ") & "." & vbCrLf
    Next
    MsgBox s, vbInformation, "Red rows"
        
End Sub
 
Код
Sub MsgRedCells()
  Dim rg As Range, s$
  For Each rg In [a1].CurrentRegion
    If rg.DisplayFormat.Interior.Color = 255 Then
      s = s & ",  " & Cells(rg.Row, 1) & ": строка = " & rg.Row & " столбец = " & rg.Column
    End If
  Next
  MsgBox Right(s, Len(s) - 3), vbCritical, "ERRORS!!!"
End Sub
Изменено: Ігор Гончаренко - 09.12.2019 16:11:58
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
МатросНаЗебре написал:
Sub LookRed()
Очень спасибо за код! Но интегрировать в файл не могу... Run-time error '429' ActiveX component can't create object и CylanceProtect ругается (action blocked)
Можно попросить прислать тестовый файл с кодом внутри?
debugger подсвечивает строчку:
Код
Set dic = CreateObject("Scripting.Dictionary")
 
Цитата
Ігор Гончаренко написал:
Sub MsgRedCell()
Игорь, спасибо! В общем-то, ваше решение подходит для точной идентификации ячейки по координатам строка/столбец. Жаль, что не получилось реализовать через указание названия столбца
 
Цитата
Николай_33445 написал:
Можно попросить прислать тестовый файл с кодом внутри?
Из-за настроек рабочего сервера файл загрузить не могу.
Цитата
Николай_33445 написал:
debugger подсвечивает строчку:
А можете руками подключить библиотеку Tools - References - Microsoft Scripting Runtime?
тогда проблемную строку надо заменить на
Код
Set dic = New Dictionary
 
Цитата
МатросНаЗебре написал: подключить библиотеку Tools - References - Microsoft Scripting Runtime
Галочку поставил
Цитата
тогда проблемную строку надо заменить
заменил. теперь debugger светит строчку:
Код
Set dic.Item(Cells(y, 1).Value) = CreateObject("Scripting.Dictionary")

ну и по традиции Cylance ругается...

 
Цитата
Николай_33445 написал:  теперь debugger светит строчку...
Что же делать?!!! :)

Цитата
ну и по традиции Cylance ругается...
Это что за зверь?
Имхо, надо, чтоб он разрешил выполнение макроса.
Изменено: МатросНаЗебре - 10.12.2019 14:34:17
 
Цитата
МатросНаЗебре написал:
Что же делать?!!!
Ну мне остается тлько каяться и плакать, что я нифига не понял что от меня хочет этот проклятый VBA! Поделитесь источником вашей мудрости, о МатросНаЗебре :cry:
Цитата
МатросНаЗебре написал:
Это что за зверь?
Да копротивный антивирь что ли... я хз, эта гадость мне тут всю малину обоср@ла :evil:  
 
Код
Set dic.Item(Cells(y, 1).Value) = New Dictionary
Мне показалось, что ответ был очевиден. Проехали.
 
Цитата
Николай_33445 написал:
Жаль, что не получилось реализовать через указание названия столбца
не жаль, я просто не решал такой задачи
потому что не определено что такое "название столбца"
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Премного благодарен уважаемым гуру Экселя!
Всё работает, получил 3 варианта реализации решения вопроса! Всем добра и новогоднего настроения! :)  
 
Цитата
Николай_33445 написал:
debugger подсвечивает строчку: Код ? 1Set dic = CreateObject("Scripting.Dictionary")
возможно, дебагер выругался на наличие матерщины в коде))
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Уважаемые знатоки! Хочется сказать, как один печально известный политик - "Я устал... я ухожу"... при "трансплантации" кода в оригинальный файл выяснилось, что ячейки, закрашенные красным в результате обработки УФ, не воспринимаются как "красные" (цвет не 255)... соответственно, нет ниодной строчки с красными ячейками. Завтра организую новый тестовый файл... буду благодарен, если откликнитесь :cry:  
 
используйте код из сообщения #3
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
Ігор Гончаренко написал:
возможно, дебагер выругался на наличие матерщины в коде))
Блин, откуда дебагер узнал, о чём я думал, когда писал код :)
 
Уважаемые гуру!
Решение несколько видоизменилось, и по здравому размышлению приняли, что лучше размещать результаты на отдельной вкладке (Results). Там же для по кнопке для удобства запускаем Текст по столбцам.
Первый (основной) макрос долго обсчитывает... как оптимизировать не догадаюсь... Одна надежда на вас.

Подскажите, где ошибка?

Заранее спасибо!
 
Код
Sub MsgRedCells()
  Dim arr(2000) As String
  Dim j As Integer
  Dim str As Variant
  j = 1
  arr(0) = "Человек;Строка;Столбец"
  Dim rg As Range, s$
  For Each rg In [a1].CurrentRegion
    If rg.DisplayFormat.Interior.Color = 255 Then
'      s = s & ",  " & Cells(rg.Row, 1) & ": Строка = " & rg.Row & " Столбец = " & rg.Column & vbCrLf
      arr(j) = Cells(rg.Row, 1) & ";" & rg.Row & ";" & rg.Column
      j = j + 1
    End If
  Next
'  For i = 0 To (UBound(arr) - LBound(arr))
'    Sheets("Results").Range("A" & i + 1) = arr(i)
'  Next i
    Sheets("Results").Range("A1").Resize(UBound(arr) - LBound(arr) + 1) = Application.Transpose(arr)
End Sub
Можно вывод ускорить.
 
Цитата
МатросНаЗебре написал:
Можно вывод ускорить.
Спасибо! Теперь всё супер!
Страницы: 1
Наверх