Using Code to copy & paste data. How can I prevent macro from pasting the same values twice

[Corried]

Hello excel world.

I have a problem.

I received updated data from excel web, through power queries table.

Every week the data updates selective rows, depending on the time of the month etc.

Example:

https://imgur.com/7f0YjOc

Each row of data represents a worksheet historical data.

Example:

https://imgur.com/aphcsjq

Now my problem here is this: when I run macro code. it copies and paste the newly selective data from power queries table.

But it also copies and paste the old data as well and make a duplicated row.

Example:

https://imgur.com/zHsyEPx

How can I modify code to prevent this from happening?

See Code below:

Sub Update_Sheets()
Dim i As Integer
Dim j As Integer
Dim country As String
Dim column1 As String
Dim last As Double

i = 1
Worksheets("PMI").Activate
Range("A1").Activate
Do While (IsEmpty(ActiveCell.Offset(i, 0).Value) = False) 'Cycles through each row on the PMI Tab

country = ActiveCell.Offset(i, 0).Value
column1 = ActiveCell.Offset(i, 1).Value
last = ActiveCell.Offset(i, 2).Value

country = strQuote & country & strQuote

Worksheets(country).Activate
Range("B2").Activate
j = 1
Do While IsEmpty(ActiveCell.Offset(j, 0).Value) = False 'cycles through rows on the country sheet to find the first empty row
j = j + 1
Loop

ActiveCell.Offset(j, 0).Value = column1
ActiveCell.Offset(j, 1).Value = last

i = i + 1
Worksheets("PMI").Activate
Range("A1").Activate
Loop
Worksheets("PMI").Activate
End Sub

Countries Indicators #1 NSB (1).xlsm

drive.google.com

 

[JoshWolski]

This should work, just add it to the end of your code. after you paste everything over this will remove duplicates

Sub RemoveDuplicate()
Dim WbWs As Worksheet
Dim LastRow As Long

Set WbWs = Workbooks("Countries Indicators #1 NSB (1) (1)").Worksheets("PMI")
LastRow = WbWs.Cells(Rows.Count, 1).End(xlUp).Row
WbWs.Range("A2:D" & LastRow).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes

End Sub

 

[DanteAmor]

How can I modify code to prevent this from happening?

Here is the updated macro. If the date already exists, then it does not copy the data.
Do you need that?
Or do you also want to check the "Last" value?

Sub Update_Sheets()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, j As Long, f As Range
  
  Set sh1 = Sheets("PMI")
  For i = 2 To sh1.Range("A:A").Find("*", , xlValues, , xlByRows, xlPrevious).Row
    Set sh2 = Sheets(sh1.Range("A" & i).Value)
    Set f = sh2.Range("B:B").Find(sh1.Range("B" & i).Value, , xlFormulas, xlWhole)
    If f Is Nothing Then
      j = sh2.Range("B:B").Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1
      sh2.Range("B" & j).Value = sh1.Range("B" & i).Value
      sh2.Range("C" & j).Value = sh1.Range("C" & i).Value
    End If
  Next
End Sub

 

[Corried]

Quote "If the date already exists, then it does not copy the data.
Do you need that"?

That right. That's the one. Thank you very much really appreciate it

Solution Solve

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.

 

[Corried]

Hello DanteAmor

The last time we chat. You have help me with this code below:

Sub Update_Sheets()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim i As Long, j As Long, f As Range

Set sh1 = Sheets("PMI")
For i = 2 To sh1.Range("A:A").Find("*", , xlValues, , xlByRows, xlPrevious).Row
Set sh2 = Sheets(sh1.Range("A" & i).Value)
Set f = sh2.Range("B:B").Find(sh1.Range("B" & i).Value, , xlFormulas, xlWhole)
If f Is Nothing Then
j = sh2.Range("B:B").Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1
sh2.Range("B" & j).Value = sh1.Range("B" & i).Value
sh2.Range("C" & j).Value = sh1.Range("C" & i).Value
End If
Next
End Sub

However. I don't know what seems to be the problem with the following workbook, I am now working on.

If you are open in helping me. Please view the link below as the file is to large to download.

Thank you in advance for your swift reply.

Money_Supply_M2.xlsm

drive.google.com