我有一段修改过的代码，我一直在使用，但效率很低。目的是检查"Database1"表中的记录是否存在于"Log1"中，如果存在，则不将记录添加到第一个可用行。Log1中有一条记录的多次迭代。Database1中应该始终只有一个记录实例。
-
每次运行代码时，它都会替换Database1中的所有记录。
-
它似乎在检查row1 database1与row1 Log1，而不是整个范围，所以它为一条记录复制多个条目，即使它已经存在。
有人能帮忙吗？抱歉，如果我没有清楚地表达出来，请询问，如果需要，我会补充更多细节。
Option Explicit
Sub Checkrecordthenaddifnotexists()
Dim Ws As Worksheet
Dim i As Long, j As Long
Dim k As Long
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Dim objTable As ListObject
Application.Calculation = xlCalculationAutomatic
Set sht = Worksheets("Database1")
Sheets("Database1").Select
Cells.Select
sht.Sort.SortFields.Clear
sht.Sort.SortFields.Add Key:=Range("A:A"), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Database1").Sort
.SetRange Range("A:AB")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets("Log1").Select
Cells.Select
ActiveWorkbook.Worksheets("Log1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Log1").Sort.SortFields.Add Key:=Range("B:B"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Log1").Sort
.SetRange Range("A:AJ")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
sht.Activate
Set StartCell = Range("A2")
LastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = sht.Cells(StartCell.Row, sht.Columns.Count).End(xlToLeft).Column
On Error Resume Next
'Sheet2.ShowAllData
Sheet2.Select
Selection.AutoFilter
On Error GoTo 0
sht.Range(StartCell, sht.Cells(LastRow, LastColumn)).Select
Set objTable = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)
With ActiveSheet
.ListObjects(1).Name = "Database_v0.1"
End With
Set Ws = Sheets("Database1")
Dim RowsMaster As Integer, Rows2 As Integer
RowsMaster = Ws.Cells(1048576, 1).End(xlUp).Row
Rows2 = Worksheets("Log1").Cells(1048576, 2).End(xlUp).Row
With Worksheets("Log1")
For i = 2 To Rows2
For j = 2 To RowsMaster + 1
If .Cells(i, 1) = Ws.Cells(j, 1) Then
Exit For
End If
Next j
If j = RowsMaster + 1 Then
RowsMaster = RowsMaster + 1
For k = 2 To 8
Ws.Cells(RowsMaster, k - 1) = .Cells(i, k)
Next
End If
Next i
End With
Sheets("Database1").Activate
ActiveSheet.ListObjects("Database_v0.1").Unlist
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Range("A1:NT1048576").RemoveDuplicates Columns:=1, Header:=xlYes
Sheets("Database Repository").Columns("A").Select
Selection.NumberFormat = "0"
Sheet2.Select
Selection.AutoFilter
Application.Calculation = xlCalculationAutomatic
End Sub
这应该会对你有所帮助，整个解释在代码中：
Option Explicit
Sub Checkrecordthenaddifnotexists()
Application.Calculation = xlCalculationAutomatic
'Try to declare your variables where you are using them
'You sort 2 times, different sheets but mostly same way so,
'write another procedure with variable and give them as you need
'the procedure below needs:
'sheet to be sorted, which range will be the one to sort, the starting cell
SortMySheet ThisWorkbook.Sheets("Database1"), "A:A", ThisWorkbook.Sheets("Database1").Range("A2")
SortMySheet ThisWorkbook.Sheets("Log1"), "A:A", ThisWorkbook.Sheets("Log1").Range("A2") 'change the starting cell
'Now we will change your approach to use 2 arrays and 1 dictionary
'For that you need to go to tools-References- and then check the Microsoft Scripting Runtime reference
'This is assuming you want to add the new entries from sheet Log1 to DataBase1 when they not exist in the later.
'The arrays:
With ThisWorkbook.Sheets("DataBase1")
Dim arrMaster As Variant: arrMaster = LoadArray(ThisWorkbook.Sheets("Database1"), .Range("A2")) 'change the starting cell
End With
With ThisWorkbook.Sheets("Log1")
Dim arrLog As Variant: arrLog = LoadArray(ThisWorkbook.Sheets("Log1"), .Range("A2")) 'change the starting cell
End With
'The dictionary:
Dim IdDictionary As Dictionary: Set IdDictionary = LoadDictionary(arrMaster)
'Now the hardwork, getting the new items to the sheet Log1
AddNewEntries arrMaster, arrLog, IdDictionary
' the next 6 lines of code are useless, we didn't need to make a table, we are not going to have duplicates
' Sheets("Database1").Activate
' ActiveSheet.ListObjects("Database_v0.1").Unlist
' Range("A1").Select
' Range(Selection, Selection.End(xlToRight)).Select
' Range(Selection, Selection.End(xlDown)).Select
' ActiveSheet.Range("A1:NT1048576").RemoveDuplicates Columns:=1, Header:=xlYes
' the next 4 lines of code I don't get
' Sheets("Database Repository").Columns("A").Select
' Selection.NumberFormat = "0"
' Sheet2.Select
' Selection.AutoFilter
Application.Calculation = xlCalculationAutomatic
End Sub
Private Sub SortMySheet(ws As Worksheet, KeyRange As String, StartCell As Range)
With ws
'Get the last row and column for your whole range
Dim LastRow As Long: LastRow = .Cells(.Rows.Count, StartCell.Column).End(xlUp).Row
Dim LastColumn As Long: LastColumn = .Cells(StartCell.Row, .Columns.Count).End(xlToLeft).Column
'Sort your whole range
.Sort.SortFields.Clear
.Sort.SortFields.Add .Range(KeyRange), xlSortOnValues, xlAscending, xlSortTextAsNumbers
With .Sort
.SetRange ws.Range(StartCell, ws.Cells(LastRow, LastColumn))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
Private Function LoadArray(ws As Worksheet, StartCell As Range) As Variant
With ws
Dim LastRow As Long: LastRow = .Cells(.Rows.Count, StartCell.Column).End(xlUp).Row
Dim LastColumn As Long: LastColumn = .Cells(StartCell.Row, .Columns.Count).End(xlToLeft).Column
LoadArray = .Range(StartCell, .Cells(LastRow, LastColumn))
End With
End Function
Private Function LoadDictionary(arr As Variant) As Dictionary
Set LoadDictionary = New Dictionary
'By default dictionaries are Case sensitive, if you need to check without that then:
'LoadDictionary.CompareMode = TextCompare
'Uncheck the comment from the line above, by default I'll go with case Sensitive
Dim i As Long
For i = 1 To UBound(arr)
If Not LoadDictionary.Exists(arr(i, 1)) Then LoadDictionary.Add arr(i, 1), i
Next i
End Function
Private Sub AddNewEntries(arrMaster As Variant, arrLog As Variant, IdDictionary As Dictionary)
With ThisWorkbook.Sheets("DataBase1")
Dim i As Long, j As Long
Dim LastRow As Long
'Loop through all entries in arrLog
For i = 2 To UBound(arrLog)
'If the entry doesn't exist in the DataBase sheet then
If Not IdDictionary.Exists(arrLog(i, 1)) Then
'Calculate the first free row of data in column A for DataBase1
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
'Loop through first to last column in arrLog and paste it to DataBase1
For j = 1 To UBound(arrLog, 2)
.Cells(LastRow, j) = arrLog(i, j)
Next j
End If
Next i
End With
End Sub