Is there an efficient way to update data from one sheet to another with a match of a cell

[mecerrato]

I have a sheet that has a main tab and a data tab. I update the data tab daily by copying from a daily report I get automatically from a reporting portal. I dump that data into the data tab and have written some code to update some of the columns in the main tab. The code matches the loan number in column C, if a match is found it executes the copy and paste of the different cells I need. The code works perfectly but it is slow as I've added other columns to copy and because they are non-contiguous I had to write code for each Column I need. I am asking the experts to review my code and maybe show me a more efficient way of writing the code so it can run faster. The data it is searching through is only a couple of hundred rows, I don't think it should take too long. Here is my code:

Sub Update_Data()
ActiveSheet.Unprotect Password:="Mortgage1"
Application.ScreenUpdating = False
Dim stNow As Date
Dim sourceRng As Range
Dim destRng As Range
stNow = Now
lrowloans = Worksheets("Main").Range("A6").End(xlDown).Row
lrowdata = Worksheets("Data").Range("C11").End(xlDown).Row
Set sourceRng = Worksheets("Main").Range("A6:A" & lrowloans)
        Set destRng = Worksheets("Data").Range("C11:C" & lrowdata)
    
        Dim match As Boolean
        For Each sRng In sourceRng
    If sRng.Value <> "" Then
       With destRng
         Set dRng = .Find(What:=sRng.Value, After:=Worksheets("Data").Range("C11"), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
         If Not dRng Is Nothing Then
             Set pasteRng = Worksheets("Main").Range("E" & sRng.Row)
             Set copyRng = Worksheets("Data").Range("G" & dRng.Row & ":H" & dRng.Row)
             copyRng.Copy pasteRng
             Set pasteRng = Worksheets("Main").Range("B" & sRng.Row)
             Set copyRng = Worksheets("Data").Range("D" & dRng.Row & ":E" & dRng.Row)
             copyRng.Copy pasteRng
             Set pasteRng = Worksheets("Main").Range("D" & sRng.Row)
             Set copyRng = Worksheets("Data").Range("U" & dRng.Row & ":U" & dRng.Row)
             copyRng.Copy pasteRng
             Set pasteRng = Worksheets("Main").Range("M" & sRng.Row)
             Set copyRng = Worksheets("Data").Range("Q" & dRng.Row & ":Q" & dRng.Row)
             copyRng.Copy pasteRng
             Set pasteRng = Worksheets("Main").Range("K" & sRng.Row)
             Set copyRng = Worksheets("Data").Range("AP" & dRng.Row & ":AP" & dRng.Row)
             copyRng.Copy pasteRng
             Set pasteRng = Worksheets("Main").Range("N" & sRng.Row)
             Set copyRng = Worksheets("Data").Range("AW" & dRng.Row & ":AW" & dRng.Row)
             copyRng.Copy pasteRng
         End If
       End With
    End If
Next
    
    Application.ScreenUpdating = True
ActiveSheet.Protect Password:="Mortgage1"
End Sub

 

[mumps]

It would be easier to help and test possible solutions if you could attach a copy of your file. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary). See the yellow banner at the top of this page for instructions to attach a file.

 

[mecerrato]

I don't see the yellow banner and can't find a way of uploading a sample sheet.

 

[Fluff]

Do you have any formulae in cols G:J or L of the Main sheet that need to be kept?

 

[mecerrato]

Do you have any formulae in cols G:J or L of the Main sheet that need to be kept?

yes I do

 

[Fluff]

Ok, how about

Sub mecerrato()
   Dim Ary As Variant, Aary As Variant, Kary As Variant, Mary As Variant
   Dim r As Long, nr As Long
   
   With Sheets("Data")
      Ary = .Range("C11:AW" & .Range("C" & Rows.Count).End(xlUp).Row).Value2
   End With
   With Sheets("Main")
      Aary = .Range("A6:F" & .Range("A" & Rows.Count).End(xlUp).Row).Value2
   End With
   ReDim Kary(1 To UBound(Aary), 1 To 1)
   ReDim Mary(1 To UBound(Aary), 1 To 2)
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Aary)
         .Item(Aary(r, 1)) = r
      Next r
      For r = 1 To UBound(Ary)
         If .exists(Ary(r, 1)) Then
            nr = .Item(Ary(r, 1))
            Aary(nr, 2) = Ary(r, 2)
            Aary(nr, 3) = Ary(r, 3)
            Aary(nr, 4) = Ary(r, 19)
            Aary(nr, 5) = Ary(r, 5)
            Aary(nr, 6) = Ary(r, 6)
            Kary(nr, 1) = Ary(r, 40)
            Mary(nr, 1) = Ary(r, 15)
            Mary(nr, 2) = Ary(r, 47)
         End If
      Next r
   End With
   With Sheets("Main")
      .Range("A6").Resize(UBound(Aary), 6).Value = Aary
      .Range("K6").Resize(UBound(Kary), 1).Value = Kary
      .Range("M6").Resize(UBound(Mary), 2).Value = Mary
   End With
End Sub

 

[mecerrato]

Wow this works fast but it missed a bunch of records that should have worked. I think there is something weird going on with the format of the column it is trying to match. I tried copying the format using format painter from the data sheet to the main sheet but it did not work. I have both Column A in Main and Column C in Data formatted as text. What I discovered is that for the records that it is not working, if I manually type in the loan number in Main column A and then run your code it works. And when I manually type in the number it adds that excel warning that a number is stored as text (see pic). Any idea how to fix?pic). Any idea how to fix? A10 is one I manually typed in A6:A9 where not manually typed in.

 

[Fluff]

That suggests that you have a mix of text & numbers, note that changing the cell format does not change the underlying value in the cell.
Try this

Sub mecerrato()
   Dim Ary As Variant, Aary As Variant, Kary As Variant, Mary As Variant
   Dim r As Long, nr As Long
   
   With Sheets("Data")
      Ary = .Range("C11:AW" & .Range("C" & Rows.Count).End(xlUp).Row).Value2
   End With
   With Sheets("Main")
      Aary = .Range("A6:F" & .Range("A" & Rows.Count).End(xlUp).Row).Value2
   End With
   ReDim Kary(1 To UBound(Aary), 1 To 1)
   ReDim Mary(1 To UBound(Aary), 1 To 2)
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Aary)
         .Item(Aary(r, 1) & "") = r
      Next r
      For r = 1 To UBound(Ary)
         If .exists(Ary(r, 1) & "") Then
            nr = .Item(Ary(r, 1) & "")
            Aary(nr, 2) = Ary(r, 2)
            Aary(nr, 3) = Ary(r, 3)
            Aary(nr, 4) = Ary(r, 19)
            Aary(nr, 5) = Ary(r, 5)
            Aary(nr, 6) = Ary(r, 6)
            Kary(nr, 1) = Ary(r, 40)
            Mary(nr, 1) = Ary(r, 15)
            Mary(nr, 2) = Ary(r, 47)
         End If
      Next r
   End With
   With Sheets("Main")
      .Range("A6").Resize(UBound(Aary), 6).Value = Aary
      .Range("K6").Resize(UBound(Kary), 1).Value = Kary
      .Range("M6").Resize(UBound(Mary), 2).Value = Mary
   End With
End Sub

 

[mecerrato]

Wow, you are a genius!, tha worked great. One more thing, is there a way to identify the record it does not find so that I can then create a message box with some if statements to ask if it is ok to delete the entire row? so the logic would be like this, as it loops if it does not find the record a msgbox will popup with the record name from column b of main or column D of data and ask a delete yes/no question, if yes then delete if no then no action and then move on to next record. Thank you so much for your help

 

[Fluff]

Whilst it would be relatively simple to delete rows on the Data sheet that were not found on the Main sheet it would slow down the macro.