How to use VBA code to not Dont copy and paste the same information

How to use VBA code to not copy and paste the same information

Requirement:

The user has created a code that searches for a specific information in a workbook and paste it on another workbook, pasting the copied information in the sheet with the same name as the information source.

The user needs to update my final sheet (Erros.xmlm) at least once a week, because the user needs to keep the workbook updated. But if the user uses the macro again it duplicate all the information that the user already had copied.

The user's question is: Can the user create a way so excel knows if it already copied that information and then not do it again.

Here is the code the user is currently using:

Code:

Function IsWorkBookOpen(FileName As String)

Dim FF As Integer, ErrNum As Integer

Select Case ErrNum
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNum
End Select
End Function
Sub Importar()

Dim Font As Workbook
Dim Dest As Workbook
Dim pesq As Range
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim ini As Range
Dim info

info = IsWorkBookOpen("C:\Users\EU\Desktop\Projetos\Arquivos fonte\Resumo de Entrega Mensal - comparativo.xlsx")

If info = False Then
Workbooks.Open ("C:\Users\EU\Desktop\Projetos\Arquivos fonte\Resumo de Entrega Mensal - comparativo.xlsx")
End If

Set Font = Workbooks("Resumo de Entrega Mensal - comparativo.xlsx")
Set Dest = Workbooks("erros.xlsm")

For x = 1 To Font.Sheets.Count
For Z = 1 To Dest.Sheets.Count

 If Right(Font.Worksheets(x).Name, 5) = Right(Dest.Worksheets(Z).Name, 5) Then
        Set copySheet = Font.Worksheets(x)
        Set pasteSheet = Dest.Worksheets(Z)
        On Error Resume Next
        Font.Worksheets(x).Activate
        Set pesq = copySheet.Range("A1").Resize(500, 10).Find(What:="Semana", LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
        Set ini = pasteSheet.Range("A1")
            If Not pesq Is Nothing Then
            firstAddress = pesq.Address
                Do
                pesq.Select
                Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(14, 0)).Select
                Selection.Copy
                ini.PasteSpecial
                Application.CutCopyMode = False
                Set pesq = copySheet.Range("A1").Resize(500, 10).FindNext(pesq)
                Set ini = pasteSheet.Range("IV1").End(xlToLeft).Offset(, 2)
                Loop While Not pesq Is Nothing And pesq.Address <> firstAddress
            End If
        End If
Next Z
Next x

Font.Close

End Sub

https://www.ozgrid.com/forum/forum/help-forums/excel-vba-macros/1196224-dont-copy-and-paste-the-same-information

Solution:

This macro will clear the sheets in Erros before it pastes the data so each time you run the macro, you will have the most recent copy of the data.

Code:

Function IsWorkBookOpen(FileName As String)
    Dim FF As Integer, ErrNum As Integer
    Select Case ErrNum
        Case 0: IsWorkBookOpen = False
        Case 70: IsWorkBookOpen = True
        Case Else: Error ErrNum
    End Select
End Function
Sub Importar()
    Application.ScreenUpdating = False
    Dim Font As Workbook
    Dim Dest As Workbook
    Dim pesq As Range
    Dim copySheet As Worksheet
    Dim pasteSheet As Worksheet
    Dim ini As Range
    Dim info
    Dim ws As Worksheet
    info = IsWorkBookOpen("C:\Users\EU\Desktop\Projetos\Arquivos fonte\Resumo de Entrega Mensal - comparativo.xlsx")
    If info = False Then
        Workbooks.Open ("C:\Users\EU\Desktop\Projetos\Arquivos fonte\Resumo de Entrega Mensal - comparativo.xlsx")
    End If
    Set Font = Workbooks("Resumo de Entrega Mensal - comparativo2.xlsx")
    Set Dest = Workbooks("erros.xlsm")
    For Each ws In Dest.Sheets
        ws.UsedRange.ClearContents
        ws.UsedRange.ClearFormats
    Next ws
    For x = 1 To Font.Sheets.Count
        For Z = 1 To Dest.Sheets.Count
             If Right(Font.Worksheets(x).Name, 5) = Right(Dest.Worksheets(Z).Name, 5) Then
                Set copySheet = Font.Worksheets(x)
                Set pasteSheet = Dest.Worksheets(Z)
                On Error Resume Next
                Font.Worksheets(x).Activate
                Set pesq = copySheet.Range("A1").Resize(500, 10).Find(What:="Semana", LookIn:=xlValues, _
                        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                        MatchCase:=False, SearchFormat:=False)
                Set ini = pasteSheet.Range("A1")
                If Not pesq Is Nothing Then
                    firstAddress = pesq.Address
                    Do
                        pesq.Select
                        Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(14, 0)).Select
                        Selection.Copy
                        ini.PasteSpecial
                        Application.CutCopyMode = False
                        Set pesq = copySheet.Range("A1").Resize(500, 10).FindNext(pesq)
                        Set ini = pasteSheet.Range("IV1").End(xlToLeft).Offset(, 2)
                    Loop While Not pesq Is Nothing And pesq.Address <> firstAddress
                End If
            End If
        Next Z
    Next x
    Font.Close
    Application.ScreenUpdating = True
End Sub

Obtained from the OzGrid Help Forum.

Solution provided by Mumps.