Sub RetrieveTransferFigures()
Dim wbk1 As Workbook
Dim wbk2 As Workbook
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim A As Integer
Dim i As String
Dim newpath As String
Dim destbook As String
Set wbk1 = ThisWorkbook
Set WS1 = wbk1.ActiveSheet
Set WS2 = wbk1.ActiveSheet
newpath = ThisWorkbook.Path
newpath = Left(newpath, InStrRev(newpath, "\") - 1) & "\DO NOT USE\"
destbook = (Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & " copy.xlsm")
ActiveSheet.Unprotect ("tracker99")
' Check that the COPY workbook is closed
On Error Resume Next
Set wbk2 = Workbooks(destbook)
' If COPY workbook is closed then open it
If wbk2 Is Nothing Then
Application.ScreenUpdating = False
Set wbk2 = Workbooks.Open(newpath & destbook, ReadOnly:=True)
Else
i = MsgBox("COPY spreadsheet is currently in use. Please try again later", vbCritical, "COPY Spreadsheet Is In Use")
ActiveSheet.Protect ("tracker99")
Exit Sub
End If
A = 3
Do While wbk2.ActiveSheet.Range("B" & A) <> vbNullString
If wbk2.ActiveSheet.Range("B" & A) = wbk1.ActiveSheet.Range("B" & A) Then
A = A + 1
Else
wbk2.ActiveSheet.Range("B" & A & ":" & "F" & A).Copy
wbk1.ActiveSheet.Range("B" & A).PasteSpecial
A = A + 1
End If
Loop
wbk2.Close False
ActiveSheet.Protect ("tracker99")
Range("F" & A).Select
Application.ScreenUpdating = True
End Sub
Bookmarks