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

mecerrato

Board Regular
Joined
Oct 5, 2015
Messages
184
Office Version
  1. 365
Platform
  1. Windows
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:

VBA 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
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
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.
 
Upvote 0
I don't see the yellow banner and can't find a way of uploading a sample sheet.
 
Upvote 0
Do you have any formulae in cols G:J or L of the Main sheet that need to be kept?
 
Upvote 0
Ok, how about
VBA Code:
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
 
Upvote 0
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.
 

Attachments

  • test.png
    test.png
    21.2 KB · Views: 8
Upvote 0
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
VBA Code:
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
 
Upvote 0
Solution
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 :)
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,224,602
Messages
6,179,848
Members
452,948
Latest member
UsmanAli786

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top