METHOD FIND & PAST OR REPLACE BETWEEN TWO SHEETS

TEIXEIRE

New Member
Joined
Apr 17, 2020
Messages
27
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 ?


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]
 

TEIXEIRE

New Member
Joined
Apr 17, 2020
Messages
27
Office Version
  1. 365
Platform
  1. Windows
error below, sorry the file I have shared is blocked, the key is : Henkel2020

1603732598108.png

1603732409986.png
 

Some videos you may like

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,737
Office Version
  1. 365
Platform
  1. Windows
Ok, how about
VBA Code:
   With Sheets("Data")
      .Range("A3:AJ" & UsdRws).Value = Dary
      .Range("AT3:AT" & UsdRws).Value = Hary
      If nr > 0 Then
         .Range("A" & UsdRws + 1).Resize(nr, 36).Value = Nary
         .Range("AT" & UsdRws + 1).Resize(nr, 1).Value = Nhary
      End If
   End With
 
Solution

TEIXEIRE

New Member
Joined
Apr 17, 2020
Messages
27
Office Version
  1. 365
Platform
  1. Windows
Hey @Fluff !

Happy new year !!

I am still struggling with some steps of this code, and I was wondering if you could help me with an ultimate solution 😳😳
I will try to explain as best as possible.

Thanks in advance!!!!!!!
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,737
Office Version
  1. 365
Platform
  1. Windows
This is now pretty old & I can't remember what was happening. If you are still having problems, I suggest you start a new thread explaining clearly & precisely what you need.
 

Watch MrExcel Video

Forum statistics

Threads
1,128,018
Messages
5,628,174
Members
416,297
Latest member
Kara Payne

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
Top