Insert And Delete Worksheets In The Same Macro

[AlexRoberts]

I have developed, with the help of contributors to this site (thank you) a couple of macros which insert and delete a worksheet from a workbook that is shown in a list (Sheet1).

I want to tidy up the code, make it more efficient / easier to read and so now want to combine the two macros. This will also allow for the checking of open workbooks more efficiently.

To show the code I have enclosed the workbook (template) that I use.

Is this possible?

[Bob Phillips]

Is this what you want (BTW, don't you find all of those obvious comments intrusive, I certainly do).

Public Sub InsertWorksheets()

    'Declare local variables.
    Dim strCurPath As String
    Dim strFile As String
    Dim ws As Worksheet

    ' Change this path to desired. Be sure to include the ending \
    Const strFldrPath As String = "Z:\Working Time Test\Working Time Records\"
    
    'Set up a dummy variable to hold the current path.
    strCurPath = "Z:\Working Time Test\Working Time Records\"
    
    'Turn off screen updating so the code will run faster.
    Application.ScreenUpdating = False
        
    'Turn events off so we are not asked to update links.
    Application.EnableEvents = False
    
    Dim wb As Workbook, wsActive As Worksheet, FileCell As Range
    
    Set wsActive = ActiveWorkbook.ActiveSheet
    
    For Each FileCell In Intersect(ActiveWorkbook.Sheets("Sheet1").UsedRange, ActiveWorkbook.Sheets("Sheet1").[A:A])
        If Dir(strFldrPath & FileCell.Text) <> vbNullString Then
            Set wb = Workbooks.Open(Filename:=strFldrPath & FileCell.Text)
            wsActive.Copy After:=wb.Sheets(wb.Sheets.Count)
            wb.Close True
        End If
    Next FileCell

    'Get the first file in the path.
    strFile = Dir(strCurPath & "*.xls")
        
    'Loop through each file in the directory.
    Do While strFile <> ""
        'Open the workbook that is being examined.
        Workbooks.Open strCurPath & strFile, False
        'Turn events back on.
        Application.EnableEvents = True
        'Check if the workbook opened as read only.
        If ActiveWorkbook.ReadOnly = True Then
            'If so, list it in the first available row in column A of sheet2.
            ThisWorkbook.Sheets("Sheet2").Cells(ThisWorkbook.Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Value = ActiveWorkbook.Name
            'Close the workbook without saving.
            ActiveWorkbook.Close False
        'If not opened in read only, search for worksheet to delete.
        Else
            'Loop through each worksheet in the current workbook.
            For Each ws In ActiveWorkbook.Worksheets
                'Check if the worksheet is the one you want to delete.
                If ws.Name = "15 Nov 10 - 13 Mar 11" Then
                'Turn display alerts off so we are not asked to answer any warning messages.
                Application.DisplayAlerts = False
                    'Delete the sheet.
                    ws.Delete
                End If
            Next ws
            'Save and close the workbook.
            ActiveWorkbook.Close True
        End If
        'Go to the next file.
        strFile = Dir()
    Loop
    
    'Turn display alerts and screen updating back on.
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
End Sub

[AlexRoberts]

Bob,

Thank you, but not quite.

I accept your comment on the comments, which was one of the reasons for wanting to streamline the code.

What I wanted to achieved was taking the code below, add two things -

For Each FileCell In Intersect(ActiveWorkbook.Sheets("Sheet1").UsedRange, ActiveWorkbook.Sheets("Sheet1").[A:A])
If Dir(strFldrPath & FileCell.Text) <> vbNullString Then
Set wb = Workbooks.Open(Filename:=strFldrPath & FileCell.Text)
wsActive.Copy After:=wb.Sheets(wb.Sheets.Count)
wb.Close True
End If
Next FileCell

Firstly, if the ActiveWorkbook.ReadOnly, then list it in the first available row in column A of Sheet2 and close the workbook with out saving.

Secondly, delete a worksheet called ‘15 Nov 10 - 13 Mar 11’

[AlexRoberts]

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)
' wb.Close True
' End If

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

[foxguy]

I'm just responding to the error.
There doesn't appear that the error is referring to this code.
That error generally means you have an "If" without an "End If", or "With" without an "End With", etc. As you can see when the code is indented properly, all your "If"s, "With"s, etc have matching code.

So it probably means that it crashed when it tried to run a different sub (like Workbook_Open) in one of the files being opened. Since it doesn't compile the external subs until it tries to run them, you wouldn't get the error until you opened (or tried to open) the file with the error.

If you step through the code 1 line at a time, you will determine which file has the error in it.

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)
            ' wb.Close True
            ' End If

            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