Fast VBA to Post 1000's of data points that show cell value ("Y") in another worksheet

[ianawwalker]

I need to combine two files to find data points, which i have the VBA for, but am struggling to write the vba to update a cell if it doesn't match the data in my combined file. found if statements, but they run extremely slow and these files have a large amount of data within them. see my current vba below. thank you for any help!

Sub DB_Combine_InportToRecords()

Application.ScreenUpdating = False
Call TurnoffFunctionality

Sheets("DB_FileInput").Range("N:N").TextToColumns
Sheets("DB_Exceptions").Range("B:B").TextToColumns

'copy loan numbers & info to db_combine tab
'loan number
Worksheets("DB_FileInput").Range("n3:n25000").Copy
Worksheets("DB_Combine").Range("A2").PasteSpecial xlPasteValues
'alt loan #
Worksheets("DB_FileInput").Range("o3:o25000").Copy
Worksheets("DB_Combine").Range("b2").PasteSpecial xlPasteValues
'borrower
Worksheets("DB_FileInput").Range("p3:p25000").Copy
Worksheets("DB_Combine").Range("f2").PasteSpecial xlPasteValues
'address
Worksheets("DB_FileInput").Range("t3:t25000").Copy
Worksheets("DB_Combine").Range("g2").PasteSpecial xlPasteValues

'pulling in data from records tab matching loan numbers
With Sheets("DB_Combine")

.Range("H2:H" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-7],Records!C[-7]:C[31],39,FALSE)"
.Range("I2:I" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-8],Records!C[-8]:C[30],34,FALSE)"
.Range("J2:J" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-9],Records!C[-9]:C[29],24,FALSE)"

End With

'comparing records tab to exception report
With Sheets("DB_Combine")

.Range("K2:K" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=MATCH(RC[-8],RC[-3],0)"
.Range("L2:L" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=MATCH(RC[-9],RC[-4],0)"
.Range("M2:M" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=MATCH(RC[-10],RC[-5],0)"

End With

'if statement to find any changes that need to be done in records tab (Y)
With Sheets("DB_Combine")

.Range("N2:N" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=IF(AND(RC[-6]=""Y"",RC[-3]=0),""Y"",""N"")"
.Range("O2:O" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=IF(AND(RC[-6]=""Y"",RC[-3]=0),""Y"",""N"")"
.Range("P2:P" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=IF(AND(RC[-6]=""Y"",RC[-3]=0),""Y"",""N"")"
   
End With

'pasting value instead of formulas
Dim LastRowColumnA As Long
LastRowColumnA = Cells(Rows.Count, 1).End(xlUp).Row
Sheets("DB_Combine").Range("H2:P" & LastRowColumnA).Select
Selection.Copy
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
       
'match DB exception Y/N to Records index/match and paste (1,0) in to columns K, L, & M
'if any loan from column A has a 0 in column K, need it to update cell (in column AM) in "Records" sheet to put a "Y". only want cell to update if column K has a 0, if column K has a 1 do not change value




MsgBox ("DB File Uploaded")

'clear contents
Range("DB_Input").ClearContents
Sheets("DB_Input").Select

Application.ScreenUpdating = True
Call TurnOnFunctionality

End Sub

 

[offthelip]

The really fast way to do this is to do it entirely in VBA and thus avoid writing equations to the worksheet and waiting while it recalculates and then copying and pasting the results back to the worksheet.
I have worked through your code and I have tried to copy the logic but I wasn't quite sure why you seemed to have the same value columns K . L and M. It seems to me the logic you wanted for columns NOP was simply a Y on the Records tab and no Y in column C , So that is what i have put in. columns KLM don't seem to do anything.
The code uses a dictionary instead of the VLOOKUP which is super fast

Sub dictionary()
   Dim InArr As Variant
   Dim outarr() As Variant
   Dim outarrNOP() As Variant
   Dim InAry
   Dim i As Long
   Dim Dic As Object
   outcol = Array(39, 34, 24)  ' specify column to copy
   Set Dic = CreateObject("Scripting.dictionary")
   With Sheets("Records")
      InArr = .Range("A1", .Range("A" & Rows.Count).End(xlUp).Offset(, 39)).Value2 ' load all of reord data into variant array
   End With
   For i = 1 To UBound(InArr, 1)
      Dic(InArr(i, 1)) = i
   Next i
   With Sheets("Db_Combine")
   lastrow = .Cells(Rows.Count, "B").End(xlUp).Row
      InAry = .Range(.Cells(1, 3), .Cells(lastrow, 3)) ' load column C into variant array
      ReDim outarr(1 To UBound(InAry), 1 To 3)
      ReDim outarrNOP(1 To UBound(InAry), 1 To 3)
          For j = 1 To UBound(InAry)
          If Dic.Exists(InAry(j, 1)) Then
          indi = Dic(InAry(j, 1))
            For k = 1 To 3
             outarr(j, k) = InArr(indi, outcol(k - 1)) ' copy row to output array
            Next k
           End If
          Next j
    .Range(.Cells(1, 8), .Cells(lastrow, 9)) = outarr  ' this outputs columns H to J
 '''''''''''''''''''''
  ' Column C is
   ' loop through output array and check for "Y" in column H , I and J  and compare to Column C
   ' If H =Y and C <> Y then put Y in columns N O and P
   For i = 2 To lastrow
    For j = 1 To 3
    If InAry(i, 1) <> "Y" And outarr(i, j) = "Y" Then
      outarrNOP(i, j) = "Y"
    Else
      outarrNOP(i, j) = "N"
    End If
    Next j
   Next i
    .Range(.Cells(1, 14), .Cells(lastrow, 16)) = outarrNOP  ' this outputs columns N to O
   End With
End Sub

Welcome to the forum!!

 

[ianawwalker]

thank you off the lip!

 

[offthelip]

Glad we could help!