Как избежать дублирования записи?

Question

Я использую кнопку «Сохранить», чтобы вставить новую запись на другой лист. Но я хочу не вставлять одни и те же данные (данные совпадают, если имя + фамилия + день рождения равны новым данным). Я пытаюсь следующий код, но он слишком медленный и не работает. Что не так с кодом ниже? Спасибо

Sub saveFormData()

  Dim name As String, lastname As String, birthday As String

  ' Get last empty row
  lastRow = Sheets("saveData").Cells(Rows.Count, 1).End(xlUp).Row + 1
  name = Worksheets("form").Range("A1").Value
  lastname = Worksheets("form").Range("A2").Value
  birthday = Worksheets("form").Range("A3").Value

  For i = 2 To lastRow

    ' Check if data exist (record is unique if we have name + lastname + birthday

    If Worksheets("saveData").Range("A" & lastRow).Value = name and Worksheets("saveData").Range("B" & lastRow).Value = lastname and Worksheets("saveData").Range("C" & lastRow).Value = birthday Then

      MsgBox "Data already exist"

      Exit Sub 'Exit from Sub

  End If
 Next

' Save name
Worksheets("saveData").Range("A" & lastRow).Value = name

' Save lastname
Worksheets("saveData").Range("B" & lastRow).Value = lastname

   ' Save birthday
   Worksheets("saveData").Range("C" & lastRow).Value = birthday

   End Sub

Answer 1

Пожалуйста, попробуйте код ниже:

Sub saveFormData()


Dim name As String, lastname As String, birthday As String

'Declare the worksheets
Dim sdSH As Worksheet, fSH As Worksheet
Set sdSH = ThisWorkbook.Sheets("saveData")
Set fSH = ThisWorkbook.Sheets("form")


' Get last empty row
lastrow = sdSH.Cells(Rows.Count, 1).End(xlUp).Row + 1
name = fSH.Range("A1").Value
lastname = fSH.Range("A2").Value
birthday = fSH.Range("A3").Value

 'Transfer the data for 'saveData to array
Dim saveData() As String
ReDim Preserve saveData(1 To lastrow, 1 To 3) As String
For a = 1 To lastrow
  For b = 1 To 3
      saveData(a, b) = sdSH.Cells(a, b).Value
  Next b
Next a


For i = 2 To UBound(saveData)

  ' Check if data exist (record is unique if we have name + lastname + birthday

  If saveData(i, 1) = name And saveData(i, 2) = lastname And saveData(i, 3) = birthday Then

      MsgBox "Data already exist"

      Exit Sub 'Exit from Sub

  End If
Next

' Save name
sdSH.Range("A" & lastrow).Value = name

' Save lastname
sdSH.Range("B" & lastrow).Value = lastname

   ' Save birthday
sdSH.Range("C" & lastrow).Value = birthday

End Sub

Answer 2

Работа с массивами и словарями - это всегда самый быстрый способ чтения больших объемов данных:

Option Explicit
Sub saveFormData()

    Dim arrSaveData
    Dim LastRow As Long
    Dim SavedData As New Scripting.Dictionary 'Need Microsoft Scripting Runtime reference to work
    Dim i As Long

    'store the saved data inside the array
    With ThisWorkbook.Sheets("saveData")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        arrSaveData = .Range("A2:C" & LastRow)
    End With

    'Save every entry into the dictionary
    For i = LBound(arrSaveData) To UBound(arrSaveData)
        SavedData.Add arrSaveData(i, 1) & arrSaveData(i, 2) & arrSaveData(i, 3), 1
    Next i

    Dim name As String, lastname As String, birthday As String

    'store your variables
    With ThisWorkbook.Sheets("form")
        name = .Range("A1")
        lastname = .Range("A2")
        birthday = .Range("A3")
    End With

    'Check if the new entry doesn't exists and if it doesn't add it
    With ThisWorkbook.Sheets("SaveData")
        If Not SavedData.Exists(name & lastname & birthday) Then
            LastRow = LastRow + 1
            .Cells(LastRow, 1) = name
            .Cells(LastRow, 2) = lastname
            .Cells(LastRow, 3) = birthday
        Else
            MsgBox "Data already exists."
        End If
    End With

End Sub

Код может не работать, если ваши данные birthday являются датами, массив будет хранить их как даты, а ваша переменная birthday является строкой, поэтому в этом случае вам следует переключить birthday As Date