METHOD FIND & PAST OR REPLACE BETWEEN TWO SHEETS

T

TEIXEIRE

New Member
Joined
Apr 17, 2020
Messages
33
Office Version
  1. 365
Platform
  1. Windows
Hello world.

I have written a VBA code to find a value in one sheet, and if match, just copy the entire row.. OK, it is not only it, let me explain how it works and the problem I am facing:

First sheet, called "DATA";
Second sheet, called "WEEK UPDATE"

1 - The person paste a pre select data in sheet "WEEK UPDATE", then push the botton to check if the value existing in its sheet, exists in the sheet "DATA";

IF YES, then the row from A to AJ ("week update") is overwritten in sheet "data" in the same colluns
IF NOT, then the row from A to AJ ("week update") is PASTED in sheet "data" in the same colluns

2 - The system check if the data in sheet "data", do not exist in sheet "week update", so put a value in collum AN as "Historic"

IF the collunm is already as "Historic", and system find the value from "Data" in "week update", then the value "historic" is overwritten as "";

.. NOW MY PROBLEM...

It works very well, but with a small quantity of lines..
I am using 50K lines in "week update" and ~40K in "data", and then the macro does not work

any help, PLEASE ?

drive.google.com

March_2020.xlsm

drive.google.com drive.google.com

follow the code:


VBA Code: 
Sub Preencher_dados()

    Application.ScreenUpdating = False
    Worksheets("Data").Unprotect Password:="Henkel2020"
    Worksheets("Week Update").Unprotect Password:="Henkel2020"
    
    Sheets("Data").Columns("AP").EntireColumn.Hidden = False
    Sheets("Week Update").Columns("AK").EntireColumn.Hidden = False
    
    linha = 3
    contagem = 0
    ultima_linha1 = Sheets("Data").Range("C80000").End(xlUp).Row
    ultima_linha2 = Sheets("Week Update").Range("C80000").End(xlUp).Row
    If ultima_linha2 <= 2 Then MsgBox "Não existem novos dados a serem transferidos.", vbExclamation: GoTo Final
    
    
    'i = 3 'concatena coluna H e I da planilha Data
    'Do While i <= ultima_linha1
    '    Sheets("Data").Cells(i, "AP") = CStr(Sheets("Data").Cells(i, "H") & Sheets("Data").Cells(i, "I"))
    '    i = i + 1
    'Loop
    
    'i = 3 'concatena coluna H e I da planilha Week Update
    'Do While i <= ultima_linha2
    '    Sheets("Week Update").Cells(i, "AK") = CStr(Sheets("Week Update").Cells(i, "H") & Sheets("Week Update").Cells(i, "I"))
    '    i = i + 1
    'Loop
    
    'verificar adição de novas linhas (Secundária busca na primária)
    
    linha = 3
    texto = "Existem materiais que necessitam de revisão na(s) linha(s): "

     Do While Sheets("Data").Cells(linha, "C") <> Empty
        Var3 = Application.Match(Sheets("Data").Cells(linha, "AP").Value, Sheets("Week Update").Columns(37),  0)
        
        If WorksheetFunction.IsError(Var3) Then 'caso 3: existe uma linha na planilha primária que foi deletada da semana atual
            linha_apagada = linha
            Sheets("Data").Cells(linha, "AN") = "Historic"
        End If
        If Not WorksheetFunction.IsError(Var3) And Sheets("Data").Cells(linha, "AN") = "Historic" Then 'caso 3: existe uma linha antes deletada que voltou semana atual
            contagem = 1
            texto = texto & vbCr & linha & ";"
            Sheets("Data").Cells(linha, "AN") = Empty
        End If
        linha = linha + 1
        
    Loop
    
    
    Do While Sheets("Week Update").Cells(linha, "C") <> Empty
        Var1 = Application.Match(Sheets("Week Update").Cells(linha, "AK").Value, Sheets("Data").Columns(42),  0)
        
        If WorksheetFunction.IsError(Var1) Then 'caso 1: existe uma nova linha na semana atual
            Sheets("Week Update").Cells(linha, 1).Resize(1, 36).Copy Destination:=Sheets("Data").Range("A80000").End(xlUp).Offset(1, 0)
        End If
        
        
        If Not WorksheetFunction.IsError(Var1) Then 'caso 2: não existe uma nova linha na semana atual -> subscrever
            linha_sub = Sheets("Data").Columns(42).Find(Sheets("Week Update").Cells(linha, "AK"), LookIn:=xlValues).Row
            Sheets("Week Update").Cells(linha, 1).Resize(1, 36).Copy Destination:=Sheets("Data").Cells(linha_sub, 1)
        End If
        linha = linha + 1
    Loop
    
    'verificar exclusão de linhas (primária busca na secundária)
    'i = 3 'concatena coluna H e I da planilha Data
    'ultima_linha1 = Sheets("Data").Range("A1048576").End(xlUp).Row
    'Do While i <= ultima_linha1
    '    Sheets("Data").Cells(i, "AP") = CStr(Sheets("Data").Cells(i, "H") & Sheets("Data").Cells(i, "I"))
    '    i = i + 1
    'Loop
    
    
    
    Application.ScreenUpdating = True
    
    If contagem = 1 Then MsgBox texto, vbExclamation
    
    
Final:
    
    Sheets("Week Update").Rows("4:80000").Delete Shift:=xlUp
    Sheets("Week Update").Range("A3:AJ3").ClearContents
    
    Sheets("Data").Columns("AP").EntireColumn.Hidden = True
    Sheets("Week Update").Columns("AK").EntireColumn.Hidden = True
    Sheets("Data").Select
    Worksheets("Data").Protect Password:="Henkel2020", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFiltering:=True
        
    Worksheets("Week Update").Protect Password:="Henkel2020"
    Application.ScreenUpdating = True

End Sub
[/CODE]
 
Sort by date Sort by votes
You're welcome & thanks for the feedback.

WE don't mark threads as solved here. :)
 
Upvote 0

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
Hello @Fluff , I hope finf you well !

Thanks for the support speeding up my macro.
I am gettig in touch with you, because people asked me to include two more colluns in the tab "Data", so I did it, and update the correspondent colluns in macro to news one.

Ex: beforeone of the key colluns was in AR, so it changed to AT.. and so on!
worked well, but the interns noticed (many months later), that if in the collun Correction they are classified with anything different of "blank" or "Historical", and the same row exists in tab "Week Update", to be update, then the value in collun "Correction" from tab "Data" gets Blank... and it should not happen, it would keep with the previous values (such as "Yes", "Remove From Report" and so on.

could you help me on that ? where should I modify on macro to get it ?

spreadsheet clicking here

Thanks in advance!
 
Upvote 0
Is this what you want
VBA Code: 
Sub DataUpdate()
Dim Dary As Variant, Hary As Variant, Uary As Variant, Nary As Variant
   Dim i As Long, c As Long, UsdRws As Long, nr As Long
   Dim Dic As Object
   
   Application.ScreenUpdating = False
   Worksheets("Data").Unprotect Password:="Henkel2020"
   

   Set Dic = CreateObject("scripting.dictionary")
   
   With Sheets("Week Update")
      UsdRws = .Range("C" & Rows.Count).End(xlUp).Row
      Uary = .Range("A3:AK" & UsdRws)
   End With
   
   With Sheets("Data")
      UsdRws = .Range("C" & Rows.Count).End(xlUp).Row
      Dary = .Range("AV3:AV" & UsdRws).Value2
      Hary = .Range("AT3:AT" & UsdRws).Value2
   End With
   
   For i = 1 To UBound(Dary)
      Dic(Dary(i, 1)) = i
   Next i
   
   With Sheets("Data")
      Dary = .Range("A3:AJ" & UsdRws).Value2
   End With
   
   ReDim Nary(1 To UBound(Uary), 1 To 36)
   For i = 1 To UBound(Uary)
      If Dic.Exists(Uary(i, 37)) Then
         For c = 1 To 36
            Dary(Dic(Uary(i, 37)), c) = Uary(i, c)
         Next c
         If Hary(i, 1) = "Historical" Then Hary(i, 1) = ""
      Else
         nr = nr + 1
         For c = 1 To 36
            Nary(nr, c) = Uary(i, c)
         Next c
         Hary(i, 1) = "Historical"
      End If
   Next i
   
   With Sheets("Data")
      .Range("A3:AJ" & UsdRws).Value = Dary
      .Range("AT3:AT" & UsdRws).Value = Hary
      .Range("A" & UsdRws + 1).Resize(nr, 36).Value = Nary
   End With
  
  Sheets("Week Update").ListObjects(1).DataBodyRange.EntireRow.Delete
  Sheets("Week Update").Range("Update[Document NumberDocument Line Number]") = "=[@[Document Number]]&[@[Document Line Number]]"
  
  Worksheets("Data").Protect Password:="Henkel2020", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, UserInterfaceOnly:=True

  Worksheets("Data").EnableOutlining = True
  
  Application.ScreenUpdating = True
    
End Sub
 
Upvote 0
Fluff said:
Is this what you want
VBA Code: 
Sub DataUpdate()
Dim Dary As Variant, Hary As Variant, Uary As Variant, Nary As Variant
   Dim i As Long, c As Long, UsdRws As Long, nr As Long
   Dim Dic As Object
  
   Application.ScreenUpdating = False
   Worksheets("Data").Unprotect Password:="Henkel2020"
  

   Set Dic = CreateObject("scripting.dictionary")
  
   With Sheets("Week Update")
      UsdRws = .Range("C" & Rows.Count).End(xlUp).Row
      Uary = .Range("A3:AK" & UsdRws)
   End With
  
   With Sheets("Data")
      UsdRws = .Range("C" & Rows.Count).End(xlUp).Row
      Dary = .Range("AV3:AV" & UsdRws).Value2
      Hary = .Range("AT3:AT" & UsdRws).Value2
   End With
  
   For i = 1 To UBound(Dary)
      Dic(Dary(i, 1)) = i
   Next i
  
   With Sheets("Data")
      Dary = .Range("A3:AJ" & UsdRws).Value2
   End With
  
   ReDim Nary(1 To UBound(Uary), 1 To 36)
   For i = 1 To UBound(Uary)
      If Dic.Exists(Uary(i, 37)) Then
         For c = 1 To 36
            Dary(Dic(Uary(i, 37)), c) = Uary(i, c)
         Next c
         If Hary(i, 1) = "Historical" Then Hary(i, 1) = ""
      Else
         nr = nr + 1
         For c = 1 To 36
            Nary(nr, c) = Uary(i, c)
         Next c
         Hary(i, 1) = "Historical"
      End If
   Next i
  
   With Sheets("Data")
      .Range("A3:AJ" & UsdRws).Value = Dary
      .Range("AT3:AT" & UsdRws).Value = Hary
      .Range("A" & UsdRws + 1).Resize(nr, 36).Value = Nary
   End With
 
  Sheets("Week Update").ListObjects(1).DataBodyRange.EntireRow.Delete
  Sheets("Week Update").Range("Update[Document NumberDocument Line Number]") = "=[@[Document Number]]&[@[Document Line Number]]"
 
  Worksheets("Data").Protect Password:="Henkel2020", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, UserInterfaceOnly:=True

  Worksheets("Data").EnableOutlining = True
 
  Application.ScreenUpdating = True
   
End Sub
Click to expand...
Thanks, I guess it is working now! :)
 
Upvote 0
You're welcome & thanks for the feedback.
 
Upvote 0
Fluff said:
You're welcome & thanks for the feedback.
Click to expand...
there is something happening, because sometimes it works and not.

file :
drive.google.com

October_2020.xlsm

drive.google.com drive.google.com


1603724647176.png
 
Upvote 0
No idea if this is what you want
VBA Code: 
Sub DataUpdate()
   Dim Dary As Variant, Hary As Variant, Uary As Variant, Nary As Variant, Nhary As Variant
   Dim i As Long, c As Long, UsdRws As Long, nr As Long
   Dim Dic As Object
   
   Application.ScreenUpdating = False
   Worksheets("Data").Unprotect Password:="Henkel2020"
   

   Set Dic = CreateObject("scripting.dictionary")
   
   With Sheets("Week Update")
      UsdRws = .Range("C" & Rows.Count).End(xlUp).Row
      Uary = .Range("A3:AK" & UsdRws)
   End With
   
   With Sheets("Data")
      UsdRws = .Range("C" & Rows.Count).End(xlUp).Row
      Dary = .Range("AV3:AV" & UsdRws).Value2
      Hary = .Range("AT3:AT" & UsdRws).Value2
   End With
   
   For i = 1 To UBound(Dary)
      Dic(Dary(i, 1)) = i
   Next i
   
   With Sheets("Data")
      Dary = .Range("A3:AJ" & UsdRws).Value2
   End With
   
   ReDim Nary(1 To UBound(Uary), 1 To 36)
   ReDim Nhary(1 To UBound(Uary), 1 To 1)
   For i = 1 To UBound(Uary)
      If Dic.Exists(Uary(i, 37)) Then
         For c = 1 To 36
            Dary(Dic(Uary(i, 37)), c) = Uary(i, c)
         Next c
         If Hary(Dic(Uary(i, 37)), 1) = "Historical" Then Hary(Dic(Uary(i, 37)), 1) = ""
      Else
         nr = nr + 1
         For c = 1 To 36
            Nary(nr, c) = Uary(i, c)
         Next c
         Nhary(nr, 1) = "Historical"
      End If
   Next i
   
   With Sheets("Data")
      .Range("A3:AJ" & UsdRws).Value = Dary
      .Range("AT3:AT" & UsdRws).Value = Hary
      .Range("A" & UsdRws + 1).Resize(nr, 36).Value = Nary
      .Range("AT" & UsdRws + 1).Resize(nr, 1).Value = Nhary
   End With
  
  Sheets("Week Update").ListObjects(1).DataBodyRange.EntireRow.Delete
  Sheets("Week Update").Range("Update[Document NumberDocument Line Number]") = "=[@[Document Number]]&[@[Document Line Number]]"
  
  Worksheets("Data").Protect Password:="Henkel2020", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, UserInterfaceOnly:=True

  Worksheets("Data").EnableOutlining = True
  
  Application.ScreenUpdating = True
    
End Sub
 
Upvote 0
Actually, since the code was updated by you on September, is right... but for any reason sometimes works and others not..
I update the file with the code you just posted, worked.. but when I went to put another data, didnt work..


the file on link below
so maybe you could help me by checking the error now :(

drive.google.com

October_2020.xlsm

drive.google.com drive.google.com
 
Upvote 0
What error do you get & which line is highlighted?
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
VBA - holidays fill
Replies
5
Views
459
mlcalves
M
T
  • Question
If not Find Replace Value
Replies
3
Views
448
TEIXEIRE
T
A
  • Question
Trying to combine data from two Excel sheets
Replies
0
Views
263
alex_345
A
T
  • Question
Macros doing anything
Replies
0
Views
323
Thestalos
T
D
  • Question
Usar texto(endereço absoluto) presente em uma célula (obtido através de uma fórmula(SE(CEL())) como critério em outras fórmulas
Replies
4
Views
550
DHero
D

Forum statistics

Threads
1,214,399
Messages
6,119,279
Members
448,884
Latest member
chuffman431a

Share this page

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