Option Explicit
Sub exampleOpenReadOnlyAndCopyWB()
'// I simply created a subfolder where ThisWorkbook resides. Change to suit."
Const SUBFOLDERNAME = "TestFolder\"
Const WBNAME = "Book2.xls"
Dim WBSource As Workbook
Dim WB As Workbook
Dim rngRow As Range
Dim rngCol As Range
Dim SheetName As Variant
Dim arrSheetNames As Variant
For Each WB In Workbooks
If UCase$(WB.Name) = UCase$(WBNAME) Then
If MsgBox("You already have a workbook named: '" & WB.Name & "' opened. " & _
"This workbook must be closed first. Close and run?", _
vbYesNo, _
vbNullString) = vbYes Then
Workbooks(WB.Name).Close False
DoEvents
Exit For
Else
Exit Sub
End If
End If
Next
Application.ScreenUpdating = False
Set WB = Application.Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & _
SUBFOLDERNAME & "Book2.xls", _
ReadOnly:=True)
For Each SheetName In Array("A", "B", "C")
'// Ensure sheet "A" (and so on) exist in both source/destination workbooks. //
If WorksheetExists(SheetName, WB) And WorksheetExists(SheetName) Then
'// Find last row/column with data in source wb. //
Set rngRow = RangeFound(WB.Worksheets(SheetName).Cells)
Set rngCol = RangeFound(WB.Worksheets(SheetName).Cells, SearchRowCol:=xlByColumns)
'// Test for empty sheet //
If Not rngRow Is Nothing Then
'// Size source range and copy //
With WB.Worksheets(SheetName)
.Range(.Cells(1, "A"), .Cells(rngRow.Row, rngCol.Column)).Copy ThisWorkbook.Worksheets(SheetName).Range("A1")
End With
Else
MsgBox "Sheet '" & SheetName & "' is empty...", vbInformation, vbNullString
End If
Else
MsgBox "Sheet '" & SheetName & "' does not exist...", vbInformation, vbNullString
End If
Next
WB.Close False
Application.ScreenUpdating = True
End Sub
Private Function WorksheetExists(ByVal SheetName As String, Optional WB As Workbook) As Boolean
If WB Is Nothing Then
Set WB = ThisWorkbook
End If
On Error Resume Next
WorksheetExists = UCase$(WB.Worksheets(SheetName).Name) = UCase$(SheetName)
On Error GoTo 0
End Function
Private Function RangeFound(SearchRange As Range, _
Optional ByVal FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range
If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange.Cells(1)
End If
Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function