1
\$\begingroup\$

I have created the code below that compare two spreadsheets . It initially compares the range of value from sheet1 ("Status") to sheet2 ("Interface") . Whenever a range matches with the ranges present in other sheet , it does nothing .When the range does not any matches in the other sheet , then the entire record is copied from sheet2 to sheet1 . I have around 1500 rows of data in both sheets with 15 columns . It takes around 30 minutes . . I look forward to see If I could get any help.

 Option Explicit

Function UpdateNEW() As Long
'   This Sub will do the Following Update
'   Run through all records in NEW
'      if found in Steps ---> Do nothing
'      if not found in Steps ----> Add it to Steps
'

Dim WSO As Worksheet
Dim WSN As Worksheet
Dim MaxRowO As Long, MaxRowN As Long, I As Long, J As Long, lAdd As Long
Dim sJob As String, sOps As String, sFirstAddress As String
Dim cCell As Range
Dim bNotFound As Boolean


'---> Disable Events
With Application
    .EnableEvents = False
    .DisplayAlerts = False
    .ScreenUpdating = False
End With

'---> Set Variables
Set WSO = Sheets("Steps")
Set WSN = Sheets("Interface")
MaxRowO = WSO.Range("A" & WSO.Rows.Count).End(xlUp).Row
MaxRowN = WSN.Range("C" & WSN.Rows.Count).End(xlUp).Row
WSN.Range("P6:P" & MaxRowN).ClearContents

'---> Loop thruough all rows in sheet New
For I = 6 To MaxRowN
    bNotFound = False
    sJob = WSN.Cells(I, "D")
    sOps = WSN.Cells(I, "E")
    Set cCell = WSO.Range("B2:B" & MaxRowO).Find(what:=sJob, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
    If Not cCell Is Nothing Then
        bNotFound = True
        sFirstAddress = cCell.Address
        Do
            '---> Check to See if Ops if found for that Job
            If WSO.Cells(cCell.Row, "C") = sOps Then
                bNotFound = False
                Exit Do
            End If
            Set cCell = WSO.Range("B2:C" & MaxRowO).FindNext(cCell)
        Loop While Not cCell Is Nothing And cCell.Address <> sFirstAddress
    Else
        bNotFound = True
    End If

    '---> Add Record to OLD if Not Found
    If bNotFound Then
        WSN.Range("C" & I & ":O" & I).Copy WSO.Range("A" & MaxRowO + 1)
        'WSN.Range("P" & I) = "Copied to OLD"
        'WSO.Range("N" & MaxRowO + 1) = sJob & " " & sOps & " Copied from New row " & I
        MaxRowO = MaxRowO + 1
        lAdd = lAdd + 1
    End If


Next I

'---> Enable Events
With Application
    .EnableEvents = True
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

UpdateNEW = lAdd

End Function
\$\endgroup\$
  • 1
    \$\begingroup\$ Welcome to Code Review! Your title probably applies to about half the code posted here. Please edit it to describe in a few words what your code does not what kind of help you're looking for. The "halp make it fasterzzz!!!" part belongs in the text of the question, as you currently have it. :) \$\endgroup\$ – FreeMan Apr 12 at 19:06
2
\$\begingroup\$

The unique data could be appended, using a Scripting Dictionary and arrays in less than a second. Alternatively, you could use an ADO Query to append records from sheet1, not in sheet2.

The easiest method would be to add all the records to the second worksheet then record a macro that:

  • Convert the range to a table
  • Select a cell in the range then click Ribbon > Table Tools > Remove Duplicates

All that is left to do is refactor the Macro to make the code dynamic.

Watch: - Excel VBA Introduction Part 25 - Arrays - Excel VBA Introduction Part 39 - Dictionaries - Excel VBA Introduction Part 32 - ADO (ActiveX Data Objects) SQL Statements (INSERT, UPDATE, DELETE)


Here is how I would rewrite the OP's code using a Scripting Dictionary and arrays.

Function UpdateNEW2() As Long
    Const Delimiter As String = "|"
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim newRows As Range
    Dim vSteps, key
    With Sheets("Steps")
        vSteps = .Range("A2:O2", .Cells(.Rows.Count, 2).End(xlUp)).Value
    End With

    Dim r As Long, c As Long, n As Long
    For r = 1 To UBound(vSteps)
        key = vSteps(r, 3) & Delimiter & vSteps(r, 4)
        Debug.Print key
        If Not dic.Exists(key) Then dic.Add key, 0
    Next

    Dim vInterface, results
    With Sheets("Interface")
        vInterface = .Range("A7:O7", .Cells(.Rows.Count, "C").End(xlUp)).Value
    End With

    ReDim results(1 To UBound(vInterface), 1 To 15)
    For r = 1 To UBound(vInterface)
        key = vInterface(r, 4) & Delimiter & vInterface(r, 5)
        Debug.Print key
        If Not dic.Exists(key) Then
            n = n + 1
            For c = 3 To 15
                results(n, c - 2) = vInterface(r, c)
            Next
        End If
    Next
    If n > 0 Then
        With Sheets("Steps")
            With .Cells(.Rows.Count, 2).End(xlUp).Offset(1)
               .Resize(n, 15).Value = results
            End With
        End With
    End If
    UpdateNEW2 = n
End Function

(Sample Data)

\$\endgroup\$
  • \$\begingroup\$ Thanks . I am new to VBA . If possible could you indicate lines where the codes can be modified . It would be of great help . \$\endgroup\$ – John Pattrick Apr 17 at 5:43
  • \$\begingroup\$ @JohnPattrick I added some untested code. Sorry, but I didn't add any comments. Let me know where you get the errors...lol. \$\endgroup\$ – TinMan Apr 17 at 6:30
  • \$\begingroup\$ Thanks for your efforts . While I am executing the code , I get Run Time Error 1004 on the code -> .Resize(n, 15).Value = results \$\endgroup\$ – John Pattrick Apr 17 at 7:53
  • \$\begingroup\$ @JohnPattrick it probably didn't return any results. Can you link me the file? \$\endgroup\$ – TinMan Apr 17 at 11:14
  • \$\begingroup\$ I have uploaded a sample worksheet of the original file . When pasted , the highlighted ones should be below the rest of file . \$\endgroup\$ – John Pattrick Apr 17 at 12:04

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.