Is this possible for vba read only

[mahmed1]

Hi All

if someone has a workbook is opened - can open that workbook for read only via VBa just to input some data in my worksheet?

if not how can i update my spreadsheet even if its open? I dont need to write to it but only read from it

thanks

 

[GTO]

Hi All

if someone has a workbook is opened - can (I) open that workbook for read only via VBa just to input some data in my worksheet?

if not how can i update my spreadsheet even if its open? I dont need to write to it but only read from it

thanks

Hi there,

What do you mean by "...input some data..." ?

If the workbook is opened by another (unless it's a shared workbook) you cannot update it and save changes. That is writing and not read-only.

Mark

 

[mahmed1]

Sorry - what i meant is that the workbook i want to copy from

so if i want to copy data from BOOK2 and say BOOK2 is already open, i want to still be able to copy the data from BOOK2 in to my workbook called BOOK1

so i dont need to write to BOOK2 just read and copy data from it and paste into my workbook calledBOOK1

hope this is more clear

 

[GTO]

Thank you. Unfortunately I am limited to Excel2003 on another PC than this one, so could you detail what it is we want to copy before I try to write some example code?

If you have the code to do the copying already written, simply opening the wb read-only is like:

ption Explicit
  
Sub exampleOpenReadOnlyWB()
Dim WB As Workbook
  
  Set WB = Application.Workbooks.Open(Filename:="C:\mwsTestTemp\TmpTest.xls", ReadOnly:=True)
  
  MsgBox WB.Name & " is open..."
  
  WB.Close False
  
End Sub

Hope that helps,

Mark

 

[mahmed1]

HI thank you

from BOOK2 - i want to copy all the data from A1 to last column and row from sheets named A, B and C to my workbook
sheet named A,B and C - cell A1

So all im doing is transferring data from
the same named sheet from 1 workbook to my workbook

am i right in saying that with your code - it will work even if the workbook is already opened?

 

[GTO]

am i right in saying that with your code - it will work even if the workbook is already opened?

Yes. Please test the code, substituting a valid path and workbook name. I am not on an actual network but switched users and am confident it should run fine. Meanwhile, I'll try and type a basic example for the copying.

Mark

 

[GTO]

Not sure when I'll log back on, so here is a try:

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

Hope that helps,

Mark

 

[mahmed1]

Thank you - i will give that a go - appreciated