Страницы: 1
RSS
Макрос на проверку задвоения данных, необходим Макрос на проверку задвоения данных при копировании
 
Доброго дня!
Оч нужна помощь,, суть такова:

Есть код:
Код
Private Sub CommandButton2_Click()
        
        If Not TypeName(Selection) = "Range" Then Exit Sub
        Dim lr&, wb As Workbook, lb As Workbook, i As Long
        With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: End With
        Set wb = GetObject("\\fs-virt\ДИС\УпрСпец\Отчеты_2019\Отчеты\NEW.xlsm")
        Set lb = ThisWorkbook
        lr = wb.Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row
        For i = 1 To Range("Таблица1").Rows.Count
        If Range("Таблица1").Cells(i, 2).Value = "" Then
            MsgBox "УДАЛИТЕ ПУСТУЮ СТРОКУ, ИЛИ ВНЕСИТЕ ДАННЫЕ!", vbCritical
            Exit Sub
        End If
    Next i
        Range("Таблица1").Copy
        wb.Sheets(1).Cells(lr + 1, 1).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        wb.Close (True)
        With Application: .EnableEvents = True: .DisplayAlerts = True: .ScreenUpdating = True: End With
        Set wb = Nothing: Set lb = Nothing
End Sub

Данный код берет данные из одной таблицы, и переносит эти данные в другой файл (таблицу). Эта таблица - форма отчета, сотрудники в нее данные вносят, тыкают на кнопку, все внесенные данные улетают в общий файл который лежит на сетевом диске.
Так вот, нужно в этот код вписать проверку данных при копировании в общую таблицу, если макрос найдет задвоение, то копирование не произойдет, и вылезет сообщение об ошибке. Проверку необходимо осуществлять не по всей таблице, а только по одному столбцу (в общей таблице это столбец "К")

в итоге, в моих представлениях, это выглядело бы так:
Нажали кнопку - запустился макрос на копирование данных в другую книгу, макрос произвел проверку на задвоение данных - ничего не копировалось и вылезло сообщение об ошибке, иначе копирование произвелось, все счастливы :)))

Заранее признателен!

P.S.
После раздумий на всем этим пришел к выводу:
В данном макросе не будет хватать еще одного кода - кода который будет выделять строку в которой есть ячейка с задвоенными данными другим цветом.
Иначе пользователь просто не сможет понять, где же те самые данные, которые необходимо скорректировать.
Изменено: Djenkinss - 11.07.2019 16:13:37
 
Файл, не видел, но проверку на дублирование можно проверять двумя способами: либо с помощью коллекций либо с помощью словарей.
И вносить на лист те данные которых нет на основном листе.
"Все гениальное просто, а все простое гениально!!!"
 
Иллюстрация подхода со словарем:
Код
Sub checkForDublicates()
    ' Подключаем словарь
    Dim valuesDic As Object
    Set valuesDic = CreateObject("Scripting.Dictionary", "")
    
    Dim checkedRn As Range, dublicatesRn As Range
    ' Проверяемый диапазон
    Set checkedRn = Range("A1:A11")
    ' Диапазон найденных дубликатов
    Set dublicatesRn = Nothing
    
    ' Пробегаемся по всем строчкам
    For i = 1 To checkedRn.Rows.Count
        ' Если в словаре есть значение проверяемой ячейки - значит это дубль.
        If valuesDic.Exists(checkedRn.Cells(i, 1).Value) Then
            ' Занесем дубль в dublicatesRn
            ' Если дублей еще нет, то диапазон ошибок - текущая ячейка
            If dublicatesRn Is Nothing Then
                Set dublicatesRn = checkedRn.Cells(i, 1)
            ' Если дубли уже есть - добавим к диапазону
            Else
                Set dublicatesRn = Union(dublicatesRn, checkedRn.Cells(i, 1))
            End If
        Else
            ' В случае если значения еще нет в диапазоне - внесем его для дальнейшего поиска дублей
            valuesDic.Add Key:=checkedRn.Cells(i, 1).Value, Item:=1
        End If
    Next i
    
    ' В случае, если диапазон с дублями не пустой
    If Not dublicatesRn Is Nothing Then
        ' Красим ячейку
        dublicatesRn.Interior.Color = vbRed
        ' Переходим к первой ячейке с ошибкой
        Application.Goto dublicatesRn, True
        ' Выдаем сообщение пользователю
        MsgBox "В данных найдены дубликаты!" & vbNewLine & "Удалите их для продолжения импорта.", vbCritical
        ' Выходим из макроса
        Exit Sub
    End If
End Sub
In GoTo we trust
 
Большое спасибо!
Буду сидеть над этим кодом кумекать.
 
Спасибо всем кто помог.
В итоге рабочий код, который без открытия второй книги сравнивает данные из активной книги с данными в общем файле.
Код
Private Sub CommandButton2_Click()
        
        If Not TypeName(Selection) = "Range" Then Exit Sub
        Dim lr&, wb As Workbook, lb As Workbook, i As Long
        With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: End With
        Set wb = GetObject("Путь к книге в которую заносятся данные из рабочей книги\Отчет.xlsm")
        Set lb = ThisWorkbook
        lr = wb.Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row
        For i = 1 To Range("таблица1").Rows.Count
            If Range("Таблица1").Cells(i, 2).Value = "" Then
                MsgBox "Удалите пустые строки", vbCritical
                Exit Sub
            End If
        Next
        For i = 1 To Range("Таблица1").Rows.Count
            a = lb.Sheets(1).Cells(i + 4, 11).Value
            For j = 47 To wb.Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row
                b = wb.Sheets(1).Cells(j, 11).Value
                If a = b Then
                    MsgBox "Найдены дубликаты!" & vbNewLine & "Проверьте введенные данные.", vbCritical
                    Exit Sub
                End If
            Next
        Next
        Range("Таблица1").Copy
        wb.Sheets(1).Cells(lr + 1, 1).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        wb.Close (True)
        With Application: .EnableEvents = True: .DisplayAlerts = True: .ScreenUpdating = True: End With
        Set wb = Nothing: Set lb = Nothing
Изменено: Djenkinss - 24.07.2019 09:26:00
Страницы: 1
Наверх