Страницы: 1
RSS
Поиск дублей в книге, Как найти дубли во всей книге
 
Добрый день. Помогите пожалуйста!!! Имеется книга ексель с несколькими листами. Необходимо проверять на наличие повторов и выводить сообщением либо подсвечивать цветом.
Код
=ЕСЛИОШИБКА("Повтор в строке "&ПОИСКПОЗ(E404;E$9:E403;);"")

Есть такой вот вариант, но по колонке, как сделать чтоб всю книгу читал?
 
Код
Sub Duo()
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    Dim v As Variant
    Dim r As Range
    Dim c As Range
    Dim cValue As String
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim di2 As Object
    Set di2 = CreateObject("Scripting.Dictionary")
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        For Each v In Array(xlCellTypeConstants, xlCellTypeFormulas)
            On Error Resume Next
                Set r = Nothing
                Set r = sh.Cells.SpecialCells(v)
            On Error GoTo 0
            If Not r Is Nothing Then
                r.Interior.Pattern = xlNone
                For Each c In r
                    cValue = c.Value
                    If cValue <> "" Then
                        If dic.Exists(cValue) Then
                            ColorCell c
                            Set di2.Item(cValue) = dic.Item(cValue)
                        Else
                            Set dic.Item(cValue) = c
                        End If
                    End If
                Next
            End If
        Next
    Next
    For Each v In di2.Items
        ColorCell v
    Next
End Sub
Sub ColorCell(ByVal c As Range)
    c.Interior.Color = RGB(255, 200, 200)
End Sub

 
Спасибо, но этот вариант не совсем подходит... Видимо плохо задачу описала. Проверка должна проходить только по определенным колонкам, по всей книге.  В этих колонках сливаются даные их трех других колонок (фио, кабинет, номер занятия). И чтобы диспетчеру облегчить труд нужно, чтоб ексель подсказывал, что такая комбинация уже есть в книге...  Есть штатные средства типа "проверка данных" возможно настройка этого инструмента лучше подойдет? Но что то настраиваю, а ничего не происходит, он не реагирует на повторы... Это временное решение проблемы пока настраивается расписание в 1С. Помогите люди добрые, а то она ночует тут... 78 групп....(((
 
Так будет искать в определённых столбцах.
Чтоб изменить столбцы, отредактируйте строку
Код
    arrCol = Array("A", "B", "C")

Код
Sub Duo()
    Dim arrCol As Variant
    arrCol = Array("A", "B", "C")
    Dim col As Variant
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    Dim v As Variant
    Dim r As Range
    Dim c As Range
    Dim cValue As String
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim di2 As Object
    Set di2 = CreateObject("Scripting.Dictionary")
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        For Each col In arrCol
            For Each v In Array(xlCellTypeConstants, xlCellTypeFormulas)
                On Error Resume Next
                    Set r = Nothing
                    Set r = sh.Columns(col).SpecialCells(v)
                On Error GoTo 0
                If Not r Is Nothing Then
                    r.Interior.Pattern = xlNone
                    For Each c In r
                        cValue = c.Value
                        If cValue <> "" Then
                            If dic.Exists(cValue) Then
                                ColorCell c
                                Set di2.Item(cValue) = dic.Item(cValue)
                            Else
                                Set dic.Item(cValue) = c
                            End If
                        End If
                    Next
                End If
            Next
        Next
    Next
    For Each v In di2.Items
        ColorCell v
    Next
End Sub
Sub ColorCell(ByVal c As Range)
    c.Interior.Color = RGB(255, 200, 200)
End Sub

 
Спасибо, сейчас попробую!
 
Спасибо.

А если выделять диапазон? Если фильтром выбрать нужную неделю, и этот диапазон строк проверить на дубли? Получается нужно каждую неделю при составлении расписания смотреть чтоб не поставить пару в занятый кабинет или занятому преподу.  
 
Код
Sub Рассписание()
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        If Not Sheet_job(sh) Then Exit Sub
    Next
End Sub

Function Sheet_job(sh As Worksheet) As Boolean
    Sheet_job = True
    Dim x As Integer
    Dim r As Range
    Dim c As Range
    Dim s As String
    For x = 5 To sh.Cells(8, Columns.Count).End(xlToLeft).Column
        Select Case Cells(8, x).Value
        Case "Фамилия И.О. преподавателя", "Каб."
            On Error Resume Next
                Set r = Nothing
                Set r = sh.Columns(x).SpecialCells(xlCellTypeConstants).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If Not r Is Nothing Then
                For Each c In r
                    If c.Row > 8 Then
                        s = Cell_job(c)
                        If s <> "" Then
                            c.Parent.Parent.Activate
                            c.Parent.Select
                            c.Select
                            Sheet_job = False
                            Alarm c, s
                            Exit Function
                        End If
                    End If
                Next
            End If
        End Select
    Next
End Function

Function Cell_job(c As Range) As String
    Dim wb As Workbook
    Set wb = c.Parent.Parent
    Dim sh As Worksheet
    Dim s As Long
    Dim f As Long
    For Each sh In wb.Worksheets
        Debug.Print c.Value, WorksheetFunction.CountIfs(sh.Rows(c.Row), c.Value)
        f = WorksheetFunction.CountIfs(sh.Rows(c.Row), c.Value)
        If f > 0 Then
            s = s + f
            Cell_job = Cell_job & vbCrLf & sh.Name
        End If
    Next    If s < 2 Then
        Cell_job = ""
    End If
End Function

Sub Alarm(c As Range, s As String)
    MsgBox "Повтор " & c.Value & vbCrLf & "на листax " & s, vbCritical, "Рассписание"
End Sub


 
Цитата
Помогите люди добрые, а то она ночует тут... 78 групп
Это вы о себе в третьем лице говорите?
Цитата
нужно каждую неделю при составлении расписания смотреть чтоб не поставить пару в занятый кабинет или занятому преподу.  
Есть книга С. М. Кашаев, СПб БХВ-Петербург,2007
«Программирование в Microsoft Excel на примерах»
Там есть глава 6, которая посвящена этому "Управление фондом аудиторий учебного заведения "
 
Вы знаете, чтото никак не найду. везде все платно, не поделитесь?

Цитата
Kuzmich написал: Это вы о себе в третьем лице говорите?
Это не о себе, а о диспетчере по расписанию. Я пробую ей помочь)

МатросНаЗебре, ошибку выдает. Надо что-то доработать?
 
Появляется окно с кнопками "Continue", "Debug"?
Или появляется окно с надписью "Повтор..."?
Скрин ошибки был бы кстати.

PS А сообщение отредактируйте.
Изменено: МатросНаЗебре - 19.11.2019 09:33:29
 
Доброе утро! Вот скрин.
 
ulka5659,IF на следующую строку перенесите
Код
Бла-бла-бла
Next    
    If s < 2 Then
        Cell_job = ""
    End If
 
еще ошибка
 
Нажмите синий квадратик под надписью Run.
Страницы: 1
Наверх