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. После раздумий на всем этим пришел к выводу: В данном макросе не будет хватать еще одного кода - кода который будет выделять строку в которой есть ячейка с задвоенными данными другим цветом. Иначе пользователь просто не сможет понять, где же те самые данные, которые необходимо скорректировать.
Файл, не видел, но проверку на дублирование можно проверять двумя способами: либо с помощью коллекций либо с помощью словарей. И вносить на лист те данные которых нет на основном листе.
"Все гениальное просто, а все простое гениально!!!"
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
Спасибо всем кто помог. В итоге рабочий код, который без открытия второй книги сравнивает данные из активной книги с данными в общем файле.
Код
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