Object Variable Or With Block Not Set

Originally and after some help I had 2 separate pieces of code, the first to copy the active worksheet into each workbook in a folder and the second to delete a named worksheet if it existed.

To make the code more efficient and use techniques I liked from both pieces of code, I have tried to merge them, the result being the code below.

However, I get the message Object Variable Or With Block Not Set.

What have I done wrong?

Public Sub Alex()

Const strFldrPath As String = "C:\Data\Communications Division\Testing Folder\Working Time Master\Working Time Records\"

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim wb As Workbook
Dim ws As Worksheet
Dim Filecell As Range

Application.ScreenUpdating = False

Set ws = ActiveWorkbook.ActiveSheet

For Each Filecell In Intersect(ActiveWorkbook.Sheets("Sheet1").UsedRange, ActiveWorkbook.Sheets("Sheet1").[A:A])
If ActiveWorkbook.ReadOnly = True Then
ThisWorkbook.Sheets("Sheet2").Cells(ThisWorkbook.Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Value = ActiveWorkbook.Name
ActiveWorkbook.Close False
ElseIf Dir(strFldrPath & Filecell.Text) <> vbNullString Then
Set wb = Workbooks.Open(Filename:=strFldrPath & Filecell.Text)
ws.Copy After:=wb.Sheets(wb.Sheets.Count)

For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "20 DEC 10 - 20 MAR 11" Then
Application.DisplayAlerts = False
ws.Delete
On Error Resume Next
End If

Next ws

End If

ActiveWorkbook.Close True

Next Filecell

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Its compiling on my system but since I don't have any dummy files, I can't run the full code. Could you upload a dummy workbook with a similar structure that you are using and indicate which line is giving you the error message.

abousetta

P.S. Please wrap the code is the [ CODE ][ /CODE ] rather than [ QUOTE ][ /QUOTE ] because the quote are more difficult to read.

AlexRoberts,


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Option Explicit
Public Sub Alex()
Const strFldrPath As String = "C:\Data\Communications Division\Testing Folder\Working Time Master\Working Time Records\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wb As Workbook
Dim ws As Worksheet
Dim Filecell As Range
Application.ScreenUpdating = False
Set ws = ActiveWorkbook.ActiveSheet

For Each Filecell In Intersect(ActiveWorkbook.Sheets("Sheet1").UsedRange, ActiveWorkbook.Sheets("Sheet1").[A:A])
  
  If ActiveWorkbook.ReadOnly = True Then
    ThisWorkbook.Sheets("Sheet2").Cells(ThisWorkbook.Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Value = ActiveWorkbook.Name
    ActiveWorkbook.Close False
  ElseIf Dir(strFldrPath & Filecell.Text) <> vbNullString Then
    Set wb = Workbooks.Open(Filename:=strFldrPath & Filecell.Text)
    ws.Copy After:=wb.Sheets(wb.Sheets.Count)
  
    For Each ws In ActiveWorkbook.Worksheets
      If ws.Name = "20 DEC 10 - 20 MAR 11" Then
        Application.DisplayAlerts = False
        ws.Delete
        On Error Resume Next
      End If
    Next ws
    
    ActiveWorkbook.Close True
    
  End If

Next Filecell

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Please use code tags not quote tags

Hi Alex,

I'm just still trying to figure out what it is you are doing exactly. Are you trying to open each of the files in the list on Sheet 1 and then if available copy the first sheet over to the current workbook?

Also this line confuses me:

    For Each Filecell In Intersect(ActiveWorkbook.Sheets("Sheet1").UsedRange, ActiveWorkbook.Sheets("Sheet1").[A:A])
        If ActiveWorkbook.ReadOnly = True Then

what are you trying to do exactly here?

Here is your code with slight modifications until we can understand it better. This should be in a standared module, not a sheet.

Option Explicit
Sub Alex()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim Filecell As Range
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Const strFldrPath As String = "C:\Data\Communications Division\Testing Folder\Working Time Master\Working Time Records\"
    
    Set ws = ActiveWorkbook.ActiveSheet

    For Each Filecell In Intersect(ActiveWorkbook.Sheets("Sheet1").UsedRange, ActiveWorkbook.Sheets("Sheet1").[A:A])
        If ActiveWorkbook.ReadOnly = True Then
            ThisWorkbook.Sheets("Sheet2").Cells(ThisWorkbook.Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Value = _
                ActiveWorkbook.Name
            ActiveWorkbook.Close False
        ElseIf Dir(strFldrPath & Filecell.Text) <> vbNullString Then
            Set wb = Workbooks.Open(Filename:=strFldrPath & Filecell.Text)
            ws.Copy After:=wb.Sheets(wb.Sheets.Count)
                For Each ws In ActiveWorkbook.Worksheets
                    If ws.Name = "20 DEC 10 - 20 MAR 11" Then ws.Delete
                Next ws
        End If
      ActiveWorkbook.Close True
    Next Filecell
       
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

abousetta

Option Explicit will not stop errors, it helps prevent you making them
Also, look at your code you needlessly switch off screen updating twice. You switch off displaalerts but don't restore it

It looks like your error handling was clicking in if the sheet isn't found. Never use error handling until the code is working

See if this is better. I've tidied the code up

Option Explicit
Public Sub Alex()

    Const strFldrPath As String = "C:\Data\Communications Division\Testing Folder\Working Time Master\Working Time Records\"
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim Filecell As Range
    
'On Error GoTo err_trap '< remove ' to restore error handling
    With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    
       
    For Each Filecell In Intersect(ActiveWorkbook.Sheets("Sheet1").UsedRange, ActiveWorkbook.Sheets("Sheet1").[A:A])
        If ActiveWorkbook.ReadOnly = True Then 'Why ????
            ThisWorkbook.Sheets("Sheet2").Cells(This 'Why?Workbook.Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Value = ActiveWorkbook.Name
            ActiveWorkbook.Close False
        ElseIf Dir(strFldrPath & Filecell.Text) <> vbNullString Then
            Set wb = Workbooks.Open(Filename:=strFldrPath & Filecell.Text)
            ws.Copy After:=wb.Sheets(wb.Sheets.Count)
                   
            For Each ws In ActiveWorkbook.Worksheets
                If ws.Name = "20 DEC 10 - 20 MAR 11" Then
                .DisplayAlerts = False
                ws.Delete
                .DisplayAlerts = True
            End If
          Next ws
        End If
      ActiveWorkbook.Close True
    Next Filecell
err_trap:
    .DisplayAlerts = True
    .ScreenUpdating = True
  End With
On Error GoTo 0
End Sub

You wiil get that error if the worksheet doesn't exist.

If a workbook is opened read only then sheets cannot be deleted

You would need to store that initial worksheet as a Public Variable & reset to that when closing