Я использую кнопку «Сохранить», чтобы вставить новую запись на другой лист. Но я хочу избежать вставки одинаковых данных (данные совпадают, если имя + фамилия + день рождения равны новым данным). Я пытаюсь следующий код, но он слишком медленный и не работает. Что не так с кодом ниже? Спасибо
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
2 ответа
Пожалуйста, попробуйте следующий код:
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
Работа с массивами и словарями - это всегда самый быстрый способ чтения больших объемов данных:
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
Новые вопросы
excel
Только для вопросов по программированию для объектов или файлов Excel или для разработки сложных формул. Вы можете объединить тег Excel с VBA, VSTO, C #, VB.NET, PowerShell, OLE-автоматизацией и другими тегами и вопросами, связанными с программированием, если это применимо. Общая помощь по MS Excel для функций одного листа доступна в Super User.