Run time error when using .select

X

XrayLemi

Board Regular
Joined
Aug 1, 2018
Messages
153
Office Version
  1. 365
Platform
  1. Windows
Hi folks.
I have a spreadsheet with VBA code that has allot of protections on it. Basically the only row on the spreadsheet that is "unlocked" for data entry is the row being used. All the rows before and after are locked. The code I wrote worked fine for days in the test files. When I added the code to the user files, I get a Run-time error '1004': Select method of range class failed.
After some research it appears that using .select may actually cause this after repeated use. This is the line of code the error appears on.

VBA Code: 
Range("B" & Rows.Count).End(xlUp).Offset(1).Select

This line of code was added because when you enter YES in a MsgBox, The row you are currently working on locks and the next row unlocks. Before I added the above line of code, sometimes the row would lock, sometimes not. Sometimes other weird things would happen. After adding that line of code, all worked well. Now suddenly out of nowhere I get the error. the attached images show what I mean.
Run Time.png
Run Time 1.png


Here is the entire code.
VBA Code: 
Private Sub CommandButton1_Click()
    UpdateDataFromMasterFile
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim r As Range, c As Range
  Set r = Union(Range("J6:J5000"), Range("G6:G5000"))
  Set r = Intersect(Target, r)
  If Not r Is Nothing Then
   Application.EnableEvents = False
   For Each c In r
    Select Case True
       Case 10 = c.Column 'J
        If c.Value = "" Then
          Cells(c.Row, "L").Value = ""
          Cells(c.Row, "L").Locked = True
          Else
          Cells(c.Row, "L").Locked = False
        End If
       Case 7 = c.Column 'G
        If c.Value = "Not Listed" Then
          Cells(c.Row, "H").Locked = False
          Else
          Cells(c.Row, "H").Locked = True
          Cells(c.Row, "H").Value = ""
        End If
       Case Else
    End Select
   Next c
  End If
  
If Target.Cells.Count > 3 Then Exit Sub
  If Not Intersect(Target, Range("C6:C5000")) Is Nothing Then
   With Target(1, 3)
    .Value = Date
    .EntireColumn.AutoFit
   End With
  End If
 
    Dim p As Range, z As Range
     Set p = Range("M6:M5000")
     Set p = Intersect(Target, p)
     If Not p Is Nothing Then
   Application.EnableEvents = False
     For Each z In p
      Select Case True
       Case 13 = z.Column 'M
        If z.Value <> "" Then
         Check = MsgBox("Are your entries correct?" & vbCrLf & "After entering yes, These values CANNOT be changed.", vbYesNo + vbQuestion, "Cell Lock Notification")
           If Check = vbYes Then
            Cells(z.Row + 1, "B").Locked = False
            Cells(z.Row + 1, "C").Locked = False
            Cells(z.Row + 1, "D").Locked = False
            Cells(z.Row + 1, "F").Locked = False
            Cells(z.Row + 1, "G").Locked = False
            Cells(z.Row + 1, "I").Locked = False
            Cells(z.Row + 1, "J").Locked = False
            Cells(z.Row + 1, "K").Locked = False
            Cells(z.Row + 1, "M").Locked = False
            If Cells(Application.ActiveCell.Row, 17).Value <> "" Then Copyemail 'Q
            If Cells(Application.ActiveCell.Row, 18).Value <> "" Then ThisWorkbook.Save 'R
            Range("B" & Rows.Count).End(xlUp).Offset(1).Select
            Target.Rows.EntireRow.Locked = True
           Else
            Cells(z.Row, "M").Value = ""
           End If
          End If
      Case Else
    End Select
   Next z
 End If
      Application.EnableEvents = True
    
End Sub

All I need is to make sure when the user enters YES, the cell in column B in the next row is the next cell ready for data input. Any ideas?
Thank you,
Jim Lemieux
 

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
Sort by date Sort by votes
I suspect your problem is caused by Copyemail which you have not supplied

This amendment should resolve things for you

Replace
Rich (BB code): 
Range("B" & Rows.Count).End(xlUp).Offset(1).Select
with
VBA Code: 
            With Me
                .Parent.Activate
                .Activate
                .Range("B" & Rows.Count).End(xlUp).Offset(1).Activate
            End With

For fuller explanation ....
1 Does the workbook contain event macro Workbook_BeforeSave?
- if it does, post the code

2 Post the code for Copyemail
 
Upvote 0
Solution
Hi Yongle,
The code that you posted seems to work fine. Still, here is the code from the module with the Copyemail sub you asked to see.
VBA Code: 
Sub Copyemail()
    Application.ScreenUpdating = False
    Workbooks.Open "S:\Radiology\FLUORO LOG BOOKS\Doctors Not On The Approved List.xlsm"
    Sheets("Sheet1").Unprotect Password:="password"
     Dim wsCopy As Worksheet
       Dim wsDest As Worksheet
       Dim lCopyLastRow As Long
       Dim lDestLastRow As Long
        Set wsCopy = ThisWorkbook.ActiveSheet
        Set wsDest = Workbooks("Doctors Not On The Approved List.xlsm").Worksheets("Sheet1")
        lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "H").End(xlUp).Row
        lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "D").End(xlUp).Offset(1).Row
        wsDest.Range("D" & lDestLastRow).Value = wsCopy.Range("H" & lCopyLastRow).Value
       wsDest.Range("B" & lDestLastRow).Value = lCopyLastRow
       wsDest.Range("A" & lDestLastRow).Value = wsCopy.Parent.Name
       wsDest.Range("C" & lDestLastRow).Value = Date
       wsDest.Activate
     Workbooks("Doctors Not On The Approved List.xlsm").Close SaveChanges:=True
     
   Dim outlookApp As Object
   Dim myMail As Object
   Set outlookApp = CreateObject("Outlook.Application")
   Set myMail = outlookApp.CreateItem(0)
   myMail.To = "me@gmail.com;you@comcast.net"
   myMail.Subject = "Doctors Not on the Approved List"
   myMail.HTMLBody = "Names have been added to the Doctors Not on the Approved List file"
   myMail.send
 End Sub

Here is the code in the Workbook section.
VBA Code: 
Private Sub Workbook_Open()
  Dim ws As Worksheet
  For Each ws In Worksheets
    ' UserInterfaceOnly:=True allows code to change data.
    ws.Protect "password", UserInterfaceOnly:=True, DrawingObjects:=True, _
      Contents:=True, Scenarios:=True, AllowFiltering:=True
  Next ws
UpdateDataFromMasterFile
End Sub

Hope you don't find any conflicts with those portions of code as well. I will be testing the code all morning.
Thank you for the fast answer.
Jim
 
Upvote 0
1. I do not like code being reliant on the active object being the "correct one"
- most of the time it will behave as expected, ocasionally it won't

EXAMPLE - the sheet below is not qualified with workbook before it. It works currently because VBA defaults the newly opened workbook as the active workbook. It would not work correctly if a line was inserrted between the 2 lines taking the focus elsewhere.
Rich (BB code): 
   Workbooks.Open "S:\Radiology\FLUORO LOG BOOKS\Doctors Not On The Approved List.xlsm"
    Sheets("Sheet1").Unprotect Password:="password"

Recommendation - go through your code and ensure that sheets and ranges are qualified to remove risk of failure
NOTE
- in sheet code (like Worksheet_Change) ... Range("A1") is cell A1 in that sheet (ie VBA assumes everything refers to that sheet unless told otherwise)
- in a module or in ThisWorkbook code window ... Range("A1") is cell A1 in the active sheet (ie VBA assumes everything refers to the active sheet unless told otherwise)

If you post your amended code I will look at it for you
- therre is no need to amend anything in the sheet code if it refers to that sheet

2. At the end of Copyemail, VBA appears to be focused on Outlook which may be the reason why you were experiencing the problem
(the error message was that VBA was unable to select the cell)

The (original code) in WorkSheet_Change EXPECTED the workbook to be active when told to select the cell in column B
- VBA cannot select a cell if the workbook is not active
- additionally t may select the wrong cell if a different sheet is active

Adding this line as the last line of Copymail would ensure that the correct workbook is active
Rich (BB code): 
ThisWorkbook.Activate

3 UpdateDataFromMasterFile ??
UpdateDataFromMasterFile is called from Worbook_Open
Please post the code
 
Last edited:
Upvote 0
Okay Yongle one thing at a time. This will take me some time to process.

First, I am not sure what you mean by qualified. I think that in these lines of code....

VBA Code: 
Workbooks.Open "S:\Radiology\FLUORO LOG BOOKS\Doctors Not On The Approved List.xlsm"
    Sheets("Sheet1").Unprotect Password:="password"

You mean the second line does not explicitly state the name of the workbook.
So I would need something like this?

VBA Code: 
Workbooks("Doctors Not On The Approved List.xlsm").Worksheets("Sheet1").Unprotect Password:="password"

Is this correct?
 
Upvote 0
Here are all the codes and modules in the workbook.

There are six worksheets per workbook.

This is the code in sheet one in the VBA project. This sheet is 2-xlSheetVeryHidden
VBA Code: 
Private Sub CommandButton1_Click()
    UpdateDataFromMasterFile
End Sub

This code is in the last five worksheets.
VBA Code: 
Private Sub CommandButton1_Click()
    UpdateDataFromMasterFile
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim r As Range, c As Range
  Set r = Union(Range("J6:J5000"), Range("G6:G5000"))
  Set r = Intersect(Target, r)
  If Not r Is Nothing Then
   Application.EnableEvents = False
   For Each c In r
    Select Case True
       Case 10 = c.Column 'J
        If c.Value = "" Then
          Cells(c.Row, "L").Value = ""
          Cells(c.Row, "L").Locked = True
          Else
          Cells(c.Row, "L").Locked = False
        End If
       Case 7 = c.Column 'G
        If c.Value = "Not Listed" Then
          Cells(c.Row, "H").Locked = False
          Else
          Cells(c.Row, "H").Locked = True
          Cells(c.Row, "H").Value = ""
        End If
       Case Else
    End Select
   Next c
  End If
  
If Target.Cells.Count > 3 Then Exit Sub
  If Not Intersect(Target, Range("C6:C5000")) Is Nothing Then
   With Target(1, 3)
    .Value = Date
    .EntireColumn.AutoFit
   End With
  End If
 
    Dim p As Range, z As Range
     Set p = Range("M6:M5000")
     Set p = Intersect(Target, p)
     If Not p Is Nothing Then
   Application.EnableEvents = False
     For Each z In p
      Select Case True
       Case 13 = z.Column 'M
        If z.Value <> "" Then
         Check = MsgBox("Are your entries correct?" & vbCrLf & "After entering yes, These values CANNOT be changed.", vbYesNo + vbQuestion, "Cell Lock Notification")
           If Check = vbYes Then
            Target.Rows.EntireRow.Locked = True
            Cells(z.Row + 1, "B").Locked = False
            Cells(z.Row + 1, "C").Locked = False
            Cells(z.Row + 1, "D").Locked = False
            Cells(z.Row + 1, "F").Locked = False
            Cells(z.Row + 1, "G").Locked = False
            Cells(z.Row + 1, "I").Locked = False
            Cells(z.Row + 1, "J").Locked = False
            Cells(z.Row + 1, "K").Locked = False
            Cells(z.Row + 1, "M").Locked = False
            If Cells(Application.ActiveCell.Row, 17).Value <> "" Then Copyemail 'Q
            If Cells(Application.ActiveCell.Row, 18).Value <> "" Then ThisWorkbook.Save 'R
            With Me
                .Parent.Activate
                .Activate
                .Range("B" & Rows.Count).End(xlUp).Offset(1).Activate
            End With
           Else
            Cells(z.Row, "M").Value = ""
           End If
          End If
      Case Else
    End Select
   Next z
 End If
      Application.EnableEvents = True
    
End Sub

This is the code in Thisworkbook
VBA Code: 
Private Sub Workbook_Open()
  Dim ws As Worksheet
  For Each ws In Worksheets
    ' UserInterfaceOnly:=True allows code to change data.
    ws.Protect "password", UserInterfaceOnly:=True, DrawingObjects:=True, _
      Contents:=True, Scenarios:=True, AllowFiltering:=True
  Next ws
UpdateDataFromMasterFile
End Sub

This code is in a module named Copy_email
VBA Code: 
Sub Copyemail()
    Application.ScreenUpdating = False
    Workbooks.Open "S:\Radiology\FLUORO LOG BOOKS\Doctors Not On The Approved List.xlsm"
    Workbooks("Doctors Not On The Approved List.xlsm").Sheets("Sheet1").Unprotect Password:="password"
     Dim wsCopy As Worksheet
       Dim wsDest As Worksheet
       Dim lCopyLastRow As Long
       Dim lDestLastRow As Long
        Set wsCopy = Workbooks("Filename.xlsm").ActiveSheet
        Set wsDest = Workbooks("Doctors Not On The Approved List.xlsm").Worksheets("Sheet1")
        lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "H").End(xlUp).Row
        lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "D").End(xlUp).Offset(1).Row
        wsDest.Range("D" & lDestLastRow).Value = wsCopy.Range("H" & lCopyLastRow).Value
       wsDest.Range("B" & lDestLastRow).Value = lCopyLastRow
       wsDest.Range("A" & lDestLastRow).Value = wsCopy.Parent.Name
       wsDest.Range("C" & lDestLastRow).Value = Date
       wsDest.Activate
     Workbooks("Doctors Not On The Approved List.xlsm").Close SaveChanges:=True
     
   Dim outlookApp As Object
   Dim myMail As Object
   Set outlookApp = CreateObject("Outlook.Application")
   Set myMail = outlookApp.CreateItem(0)
   myMail.To = "me@gmail.com;you@comcast.net"
   myMail.Subject = "Doctors Not on the Approved List"
   myMail.HTMLBody = "Names have been added to the Doctors Not on the Approved List file"
   myMail.send
 End Sub

This code is in a module named Doctor_List
VBA Code: 
Sub UpdateDataFromMasterFile()
    Dim wbMaster As Workbook
    Dim wbMinion As Workbook
    Dim wsMaster As Worksheet
    Dim wsMinion As Worksheet
    Dim noRows&
    Dim i&
    Dim arrMaster()
    Dim arrMinion()
    
    On Error GoTo ErrorHandler
    
    Const wbMasterFileDir$ = "S:\Radiology\FLUORO LOG BOOKS\Approved Fluoroscopy List.xlsm"
    
    If Not (Len(Dir(wbMasterFileDir)) > 0) Then
        MsgBox "Provided master file directory does not exist!" & vbNewLine & _
                "Path: " & wbMasterFileDir, vbCritical, "InfoLog"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Set wbMinion = ThisWorkbook
    Set wsMinion = wbMinion.Sheets(1)
    
    Set wbMaster = Workbooks.Open(wbMasterFileDir) 'GetObject(wbMasterFileDir)
    Set wsMaster = wbMaster.Sheets(1)
    
    With wsMaster
        noRows = .Range("A" & Cells.Rows.Count).End(xlUp).Row
        
        If noRows = 1 Then
            Application.ScreenUpdating = True
            MsgBox "There's no data to pull from Master File!", vbExclamation, "InfoLog"
            Exit Sub
        End If
        
        arrMaster = .Range("A2:A" & noRows)
        
        WbMasterClose wb:=wbMaster
        
        arrMinion = wsMinion.Range("A2:A" & noRows)
    End With
    
    For i = 1 To UBound(arrMaster, 1)
        arrMinion(i, 1) = arrMaster(i, 1)
    Next i
        
    wsMinion.Range("A2:A" & noRows) = arrMinion
            
    MsgBox "Update completed.", vbInformation, "InfoLog"
    
DataClearance:
    Application.ScreenUpdating = True
    Set wbMinion = Nothing
    Set wsMinion = Nothing
    Set wbMaster = Nothing
    Set wbMinion = Nothing
    
    Exit Sub

ErrorHandler:
    MsgBox "Unexpected error occured!", vbCritical, "InfoLog"
    Resume DataClearance
    
End Sub
Private Sub WbMasterClose(wb As Workbook)
    On Error Resume Next
    Application.DisplayAlerts = False
    wb.Saved = False
    wb.Close
    Application.DisplayAlerts = True
End Sub

Private Sub CommandButton1_Click()
    UpdateDataFromMasterFile
End Sub

That is everything.
I will not be at work again until Wednesday 10/7/20. I also do not have a current version of excel at home. That means I can't work on it there.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
VBA help - Locking & unlocking on certain times of day
2
Replies
17
Views
348
dmt32
D
N
  • Question Question
VBA - Intersect code being re-initiated
Replies
1
Views
190
Peter_SSs
Peter_SSs
A
  • Solved
setting a range from Active cell to last cell when Active cell change columns
2
Replies
12
Views
494
jolivanes
jolivanes
A
  • Question Question
After User Enters A Value (Validation List), Not Automatically Advancing To Next Cell As Per "Select"
Replies
1
Views
392
Ark68
A
I
  • Question Question
Listbox columns dont alter when i set the width advice please
Replies
4
Views
44
ipbr21054
I

Forum statistics

Threads
1,223,911
Messages
6,175,333
Members
452,636
Latest member
laura12345

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top