How to use VBA code to not copy and paste the same information
Category: [Excel] Demo Available
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
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.
See also: Index to Excel VBA Code and Index to Excel Freebies and Lesson 1 - Excel Fundamentals and Index to how to… providing a range of solutions and Index to new resources and reference sheets
See also:
| How to use VBA code to check interactions in the formula bar |
| How to use a VBA code for clipart |
| How to data trim and clean cell values with VBA code |
| How to run code when cell value changes from empty to entered value |
Click here to visit our Free 24/7 Excel/VBA Help Forum where there are thousands of posts you can get information from, or you can join the Forum and post your own questions.