METHOD FIND & PAST OR REPLACE BETWEEN TWO SHEETS

[TEIXEIRE]

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 ?

March_2020.xlsm

drive.google.com

follow the 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]

 

[TEIXEIRE]

Exactly it.

and the 2), one more thing, if there is a line in data sheet as "Historic" already, and in a new extraction we haveit again, then collunm "AN" change from Hisotoric to blank.

the spread is in the link above.

and the system concatenate the information in H & I, and there are already available in collunm AP in sheet Data, and AK in sheet "week update"

pleaasse, help me

with the data already avalable inattached sheet tha macro do not work,
but actually I didnt see nothing at all

 

[Fluff]

How about

Sub Teixeire()
   Dim Dary 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"
   Worksheets("Week Update").Unprotect Password:="Henkel2020"

   Set Dic = CreateObject("scripting.dictionary")
   With Sheets("Week Update")
      UsdRws = .Range("A" & Rows.Count).End(xlUp).Row
      Uary = .Range("A3:AK" & UsdRws)
   End With
   With Sheets("Data")
      UsdRws = .Range("A" & Rows.Count).End(xlUp).Row
      Dary = .Range("AP3:AP" & UsdRws).Value2
   End With
   For i = 1 To UBound(Dary)
      Dic(Dary(i, 1)) = i
   Next i
   With Sheets("Data")
      .Range("AN3:AN" & UsdRws).Value = "Historical"
      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
         Sheets("Data").Range("AN" & Dic(Uary(i, 37)) + 2) = ""
      Else
         nr = nr + 1
         For c = 1 To 36
            Nary(nr, c) = Uary(i, c)
         Next c
      End If
   Next i
   With Sheets("Data")
      .Range("A3:AJ" & UsdRws).Value = Dary
      .Range("A" & UsdRws + 1).Resize(nr, 36).Value = Nary
   End With
End Sub

It will take about 10 minutes to run, I can probably speed it up, but check that it does what you need.

 

[TEIXEIRE]

WELL PERFECT DONE!
yes, it is working ))

if there is anyway to speed up, of course would be good.
the only thing that I will do later is add 2 more collunms in Data sheet after AK;
and erase the data in weekupdate, but seems to be apiece of cake *.***

 

[Fluff]

When you say

the only thing that I will do later is add 2 more collunms in Data sheet after AK;

Do you mean add data to existing columns, or insert new columns somewhere between AK & AP?

 

[TEIXEIRE]

yES, BUT SOMEONE IS ASKING ME.
BUT IT IS ONLY MODIFY THECODE

 

[Fluff]

I can happily modify the code, but I will need to know what columns are being inserted & where the correction & Document columns will be after those columns have been inserted.

 

[Fluff]

This will be quicker & also clears the Update sheet

Sub Teixeire()
   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"
   Worksheets("Week Update").Unprotect Password:="Henkel2020"

   Set Dic = CreateObject("scripting.dictionary")
   With Sheets("Week Update")
      UsdRws = .Range("A" & Rows.Count).End(xlUp).Row
      Uary = .Range("A3:AK" & UsdRws)
   End With
   With Sheets("Data")
      UsdRws = .Range("A" & Rows.Count).End(xlUp).Row
      Dary = .Range("AP3:AP" & UsdRws).Value2
      Hary = .Range("AN3:AN" & UsdRws).Value2
   End With
   For i = 1 To UBound(Dary)
      Dic(Dary(i, 1)) = i
      Hary(i, 1) = "Historical"
   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
         Hary(Dic(Uary(i, 37)), 1) = ""
      Else
         nr = nr + 1
         For c = 1 To 36
            Nary(nr, c) = Uary(i, c)
         Next c
      End If
   Next i
   With Sheets("Data")
      .Range("A3:AJ" & UsdRws).Value = Dary
      .Range("AN3:AN" & UsdRws).Value = Hary
      .Range("A" & UsdRws + 1).Resize(nr, 36).Value = Nary
   End With
   Sheets("Week Update").ListObjects(1).DataBodyRange.EntireRow.Delete
End Sub

 

[Fluff]

Cross posted Find & replace between 2 sheets

While we do allow Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules). This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.

 

[TEIXEIRE]

Thank you so much, it runned very well!
Is there any place to mark as solved ?
Many thanks