Check if record exists and append records to bottom

Question

I have a piece of modified code which I've been using but is very inefficient. The intention was to check if records in 'Database1' sheet exists in 'Log1' if so do nothing if not add the record to first available row. There are multiple iterations of a record in Log1. There should always only be one instance of the record in Database1.

Each time the code runs it replaces all records in Database1.
It seems to be cheking row1 database1 versus row1 Log1 and not the whole range so it copies in multiple entries for one record even though it already exists.

Can anyone help? Apologies if I don't articulate this clearly please ask and I will add more detail if needed.

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

Use [.Find](http://www.siddharthrout.com/index.php/2018/01/05/find-and-findnext-in-excel-vba/) to find if the record exists. Find last row as shown [Here](https://stackoverflow.com/questions/11169445/error-in-finding-last-used-cell-in-excel-with-vba/11169920#11169920) and then append you data if required. — Siddharth Rout, Aug 11 '20 at 06:54
@roger: Also a MUST read [How to avoid using Select in Excel VBA](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba) — Siddharth Rout, Aug 11 '20 at 07:04

Damian · Accepted Answer · 2020-08-14T07:08:16.297

Well this should help you, the whole explanation is in the code:

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

sorry for late reply really appreciate the change. This returns a 'runtime error 438 Object doesn't support this property or method' at: .SetRange (StartCell, .Cells(LastRow, LastColumn)) any suggestion? — rogerbay2399, Aug 14 '20 at 06:27
@rogerbay2399 try adding `ws` just before `.Cells(LastRow, LastColumn))` — Damian, Aug 14 '20 at 06:46
thanks that works perfectly. It copies one record then returns 'run-time error 9: subscript out if range at: .cells(LsstRow, j) = arrLog(i, j) — rogerbay2399, Aug 14 '20 at 06:56
@rogerbay2399 copy the code from my edit. When you loop through the Y coordinate for an array (the columns) you must loop it like: `For j = 1 To Ubound(arr, 2)` that `, 2` means the second coordinate, or Y, or columns for that matter. — Damian, Aug 14 '20 at 07:09
my apologies i hadn't realised i made that amendment all works now. One final question if i wanted to amend the range that is copied i.e. columns A to E of the Log1 rather than the full range is that straight forward? — rogerbay2399, Aug 14 '20 at 07:17
in this final loop we corrected. You need to add a conditional, `If j = 6 Then Exit For` just above the `.Cells(LastRow, j) = arrLog(i, j)`. This way, the loop will exit when reaches column F which is index is 6. Don't forget to mark this answer as correct if it helped :). Also, wasn't your fault the last error, it was all mine but wanted to explain why it gave an error. — Damian, Aug 14 '20 at 07:19
brilliant!!!! Thanking you kindly for your help. I will do so now — rogerbay2399, Aug 14 '20 at 07:27

Check if record exists and append records to bottom

1 Answers1