UtterAccess.com
X   Site Message
(Message will auto close in 2 seconds)

Welcome to UtterAccess! Please ( Login   or   Register )

Custom Search
 
   Reply to this topicStart new topic
> Remove All Excess Worksheets, Access 2016    
 
   
aggiemarine07
post Sep 4 2019, 08:53 AM
Post#1



Posts: 75
Joined: 7-January 11



So i have a bit of complex code that does what I need it to (loop through all excel files within a folder, add a worksheet from a master file to the current workbook, and do a few other minor things). However, now on the final step, I want it to remove all worksheets not named "WFM PLOG" but cant figure out how to implement it. I have tried a few different methods including LEN >0 and such but it just isnt working (subscript out of range error). Any help would be greatly appreciated. Thanks!


CODE
Sub Command0_Click()
Dim xl As Excel.Application
Dim wbMaster As Excel.Workbook
Set xl = New Excel.Application
Set wbMaster = xl.Workbooks.Open(CurrentProject.path & "\ProjectBabelfish")

Dim wsCopy As Excel.Worksheet
Set wsCopy = wbMaster.Worksheets("Babelfish")

Dim sFolderPath As String
sFolderPath = wbMaster.path & "\PLOGs\"
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"

Dim sFileName As String
sFileName = Dir(sFolderPath & "*.xlsx")

Dim StrFile As String: StrFile = CurrentProject.path & "\PLOGs\*.xlsb"

'Disable screenupdating (to prevent "screen flickering" so macro runs smoother)
'Disable alerts (to suppress "Are you sure?" prompts during worksheet deletion)
xl.ScreenUpdating = False
xl.DisplayAlerts = False

On Error Resume Next
If Len(Dir$(StrFile)) > 0 Then
    SetAttr StrFile, vbNormal
    Kill StrFile
End If

'Begin loop through files in the folder
Do While Len(sFileName) > 0

    Dim sWBOpenPassword As String
    Dim sWBProtectPassword As String
    Select Case sFileName
        'Specify workbook names that require passwords here
        Case "book1.xlsx"
            sWBOpenPassword = "550"
            sWBProtectPassword = "550"

        'If different books require different passwords, can specify additional names with their unique passwords
        Case "Book3.xlsx"
            sWBOpenPassword = "book3openpassword"
            sWBProtectPassword = "book3protectionpassword"

        'Keep specifying excel file names and their passwords until completed
        Case "Book10.xlsx", "Book257.xlsx"
            sWBOpenPassword = "GenericOpenPW2"
            sWBProtectPassword = "GenericProtectPW2"

        'Case Else will handle the remaining workbooks that don't require passwords
        Case Else
            'MsgBox sFileName & " has a wierd password"
            sWBOpenPassword = "550"
            sWBProtectPassword = "550"

    End Select

    'Open file using password (if any)
    On Error Resume Next
    With xl.Workbooks.Open(sFolderPath & sFileName, UpdateLinks:=False, Password:=sWBOpenPassword)
        If Err.Number = 1004 Then MsgBox "The workbook " & sFileName & " is at a middle school dance."
        Dim bProtectedWB As Boolean
        bProtectedWB = False    'Reset protected wb check to false

        If .ProtectStructure = True Then bProtectedWB = True 'Check if workbook is protected and if so unprotect it using the specified protection password
        If bProtectedWB = True Then .Unprotect sWBProtectPassword
            
        .Sheets(1).Name = "Whole Foods Market PLOG"
        'MsgBox "Name of Sheets: " & .Sheets(1).Name & ", " & .Sheets(2).Name & ", " & .Sheets(3).Name
        If .Worksheets("Whole Foods Market PLOG").Range("A20") = "" Then
                .Sheets(1).Delete
                .Sheets(1).Name = "Whole Foods Market PLOG"
                End If
            
        On Error Resume Next    'Suppress error if copied worksheet does not yet exist
        .Worksheets(wsCopy.Name).Delete 'Delete existing sheet if it exists
        On Error GoTo 0         'Remove "On Error Resume Next" condition
    
            wsCopy.Copy after:=.Worksheets(.Worksheets.Count)   'Copy template into the workbook
            .Worksheets(wsCopy.Name).Cells.Replace wbMaster.Name, .Name 'Change references from master workbook to current workbook
                        
            .Worksheets("Babelfish").Activate
            .Worksheets("Babelfish").Range("A2:Y2").Select
            .Worksheets("Babelfish").Range("A2:Y2").Copy
            .Worksheets("Babelfish").Range("A2:Y2").PasteSpecial Paste:=xlPasteValues
            .Worksheets("Babelfish").Range("AA2:AE201").Select
            .Worksheets("Babelfish").Range("AA2:AE201").Copy
            .Worksheets("Babelfish").Range("AA2:AE201").PasteSpecial Paste:=xlPasteValues
            .Worksheets("Babelfish").Range("AH2:CK201").Select
            .Worksheets("Babelfish").Range("AH2:CK201").Copy
            .Worksheets("Babelfish").Range("AH2:CK201").PasteSpecial Paste:=xlPasteValues
            
            .Sheets(2).Name = "WFM PLOG"
            
'---> This is where I want to delete all excess worksheets
            If Len(.Sheets(9).Name) > 0 Then
                If .Sheets(9).Name <> "WFM PLOG" Then .Sheets(9).Delete
                Else: Resume Next
                End If
            If Len(.Sheets(8).Name) > 0 Then
                If .Sheets(8).Name <> "WFM PLOG" Then .Sheets(8).Delete
                Else: Resume Next
                End If
            If Len(.Sheets(7).Name) > 0 Then
                If .Sheets(7).Name <> "WFM PLOG" Then .Sheets(7).Delete
                Else: Resume Next
                End If
            If Len(.Sheets(6).Name) > 0 Then
                If .Sheets(6).Name <> "WFM PLOG" Then .Sheets(6).Delete
                Else: Resume Next
                End If
            If Len(.Sheets(5).Name) > 0 Then
                If .Sheets(5).Name <> "WFM PLOG" Then .Sheets(5).Delete
                Else: Resume Next
                End If
            If Len(.Sheets(4).Name) > 0 Then
                If .Sheets(4).Name <> "WFM PLOG" Then .Sheets(4).Delete
                Else: Resume Next
                End If
            If Len(.Sheets(3).Name) > 0 Then
                If .Sheets(3).Name <> "WFM PLOG" Then .Sheets(3).Delete
                Else: Resume Next
                End If
            If Len(.Sheets(2).Name) > 0 Then
                If .Sheets(2).Name <> "WFM PLOG" Then .Sheets(2).Delete
                Else: Resume Next
                End If
            If Len(.Sheets(1).Name) > 0 Then
                If .Sheets(1).Name <> "WFM PLOG" Then .Sheets(1).Delete
                Else: Resume Next
                End If
'--->End of where I want to delete all excess worksheets
                                                    
            If bProtectedWB = True Then .Protect sWBProtectPassword   'If workbook was protected, reprotect it with same protection password
        
        If Not IsEmpty(varLinks) Then
            For i = 1 To UBound(varLinks)
                .BreakLink _
                    Name:=varLinks(i), _
                    Type:=xlLinkTypeExcelLinks
            Next i
        End If
        
        .SaveAs FileName:=sFolderPath & Mid(sFileName, 1, Len(sFileName) - 5) & ".xlsb", FileFormat:=xlExcel12, CreateBackup:=False
        .Save
        .Close True

    End With
      
    sFileName = Dir 'Advance to next file in the folder
    
Loop

'Re-enable screenupdating and alerts
xl.ScreenUpdating = True
xl.DisplayAlerts = True
xl.Quit

MsgBox "Added Tab to all PLOG files"

End Sub

Private Sub Command1_Click()
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE * FROM BabelfishImport"
Call Import_Excel
Call DeleteImportErrors
MsgBox "Finished import all excel files"
DoCmd.SetWarnings True
End Sub

Private Sub Command4_Click()
Dim xl As Excel.Application
Set xl = New Excel.Application

xl.ScreenUpdating = False
xl.DisplayAlerts = False
Call LoopAllExcelFilesInFolder

End Sub
Go to the top of the page
 
DanielPineault
post Sep 4 2019, 09:08 AM
Post#2


UtterAccess VIP
Posts: 7,011
Joined: 30-June 11



What about a function along the lines of
CODE
Sub DeleteWorkSheets()
    Dim Sht                   As Excel.Worksheet

    Application.DisplayAlerts = False
    For Each Sht In ThisWorkbook.Worksheets
        Select Case Sht.Name
        Case Is <> "WFM PLOG"
            Sht.Delete
        End Select
    Next Sht
    Application.DisplayAlerts = True
End Sub

--------------------
Daniel Pineault (2010-2019 Microsoft MVP, UA VIP, EE Distinguished Expert 2018)
Professional Help: https://www.cardaconsultants.com
Free MS Access Code, Tips, Tricks and Samples: https://www.devhut.net

* Design should never say "Look at me". It should always say "Look at this". -- David Craib
* A user interface is like a joke, if you have to explain it, it's not that good! -- Martin LeBlanc


All code samples, demonstration databases, links,... are provided 'AS IS' and are to be used at your own risk! Take the necessary steps to check, validate ...(you are responsible for your choices and actions)
Go to the top of the page
 
arnelgp
post Sep 4 2019, 09:26 AM
Post#3



Posts: 1,510
Joined: 2-April 09
From: somewhere out there...


CODE

    Dim Sht  As Worksheet
    Application.DisplayAlerts = False
    For Each Sht In .Worksheets
        Select Case UCase(Sht.Name)
        Case "wfm_plog", "babelfish"
        Case Else
            Sht.Delete
        End Select
    Next Sht

This post has been edited by arnelgp: Sep 4 2019, 09:27 AM

--------------------
Never stop learning, because life never stops teaching.
Go to the top of the page
 
aggiemarine07
post Sep 4 2019, 09:34 AM
Post#4



Posts: 75
Joined: 7-January 11



@DanielPineault I tried that method as I found it elsewhere on the internet and I get a "run time error 1004; method 'thisworkbook' of object '_global' failed" within the function at
CODE
For Each Sht In ThisWorkbook.Worksheets
Go to the top of the page
 
DanielPineault
post Sep 4 2019, 09:34 AM
Post#5


UtterAccess VIP
Posts: 7,011
Joined: 30-June 11



If you use arnelgp's example, be sure to turn the DisplayAlerts back on by add the following line to the end of the procedure
CODE
Application.DisplayAlerts = True

--------------------
Daniel Pineault (2010-2019 Microsoft MVP, UA VIP, EE Distinguished Expert 2018)
Professional Help: https://www.cardaconsultants.com
Free MS Access Code, Tips, Tricks and Samples: https://www.devhut.net

* Design should never say "Look at me". It should always say "Look at this". -- David Craib
* A user interface is like a joke, if you have to explain it, it's not that good! -- Martin LeBlanc


All code samples, demonstration databases, links,... are provided 'AS IS' and are to be used at your own risk! Take the necessary steps to check, validate ...(you are responsible for your choices and actions)
Go to the top of the page
 
DanielPineault
post Sep 4 2019, 09:35 AM
Post#6


UtterAccess VIP
Posts: 7,011
Joined: 30-June 11



It depends on how you are implementing things, but try simply switching
CODE
For Each Sht In ThisWorkbook.Worksheets

to
CODE
For Each Sht In .Worksheets


You should truly define a workbook object variable then you could more easily work with the workbook and pass it to called procedures and the likes.

--------------------
Daniel Pineault (2010-2019 Microsoft MVP, UA VIP, EE Distinguished Expert 2018)
Professional Help: https://www.cardaconsultants.com
Free MS Access Code, Tips, Tricks and Samples: https://www.devhut.net

* Design should never say "Look at me". It should always say "Look at this". -- David Craib
* A user interface is like a joke, if you have to explain it, it's not that good! -- Martin LeBlanc


All code samples, demonstration databases, links,... are provided 'AS IS' and are to be used at your own risk! Take the necessary steps to check, validate ...(you are responsible for your choices and actions)
Go to the top of the page
 
aggiemarine07
post Sep 4 2019, 09:38 AM
Post#7



Posts: 75
Joined: 7-January 11



@arnelgp thanks for the response smile.gif

I get an invalid procedure or argument (runtime error 5) at
CODE
sFileName = Dir 'Advance to next file in the folder
Go to the top of the page
 
aggiemarine07
post Sep 4 2019, 09:44 AM
Post#8



Posts: 75
Joined: 7-January 11



@DanielPineault thanks so much for your help! After making your recommended adjustment, now I get: Compile Error, invalid or unqualified reference at
CODE
For Each Sht In .Worksheets
Go to the top of the page
 
arnelgp
post Sep 4 2019, 10:02 AM
Post#9



Posts: 1,510
Joined: 2-April 09
From: somewhere out there...


you have 2 dir on the beginning of the sub.
first dir, for sFileName, 2nd strFile.
it will remember the last dir() you made.

to prevent this, add all sFileName to a collection object
and loop through this collection and not executing dir() again:
CODE
Dim colFiles as New Collection
Dim sFileName As String
Dim i As Integer
sFileName = Dir(sFolderPath & "*.xlsx")
While sFileName <> ""
   colFiles.Add sFolderPath & sFileName
   sFileName = Dir
Wend

replace this line:
CODE
Do While Len(sFileName) > 0

with:
CODE
For i = 1 to colFiles.Count
sFileName = colFiles(i)

remove the "Loop" at the end and replace with "Next"
remove also the "Dir" at the end of the loop.

edit:
you will need to replace this also:
CODE
   With xl.Workbooks.Open(sFolderPath & sFileName, UpdateLinks:=False, Password:=sWBOpenPassword)

with:
CODE
   With xl.Workbooks.Open(sFileName, UpdateLinks:=False, Password:=sWBOpenPassword)

sFilename already has the Path when we save it to collection object.
This post has been edited by arnelgp: Sep 4 2019, 10:19 AM

--------------------
Never stop learning, because life never stops teaching.
Go to the top of the page
 
DanielPineault
post Sep 4 2019, 10:07 AM
Post#10


UtterAccess VIP
Posts: 7,011
Joined: 30-June 11



Dir is only for very simple use cases. When you need to perform complex operations, loops within loops, ... then you should turn towards FSO instead as it doesn't suffer from the same issues.

--------------------
Daniel Pineault (2010-2019 Microsoft MVP, UA VIP, EE Distinguished Expert 2018)
Professional Help: https://www.cardaconsultants.com
Free MS Access Code, Tips, Tricks and Samples: https://www.devhut.net

* Design should never say "Look at me". It should always say "Look at this". -- David Craib
* A user interface is like a joke, if you have to explain it, it's not that good! -- Martin LeBlanc


All code samples, demonstration databases, links,... are provided 'AS IS' and are to be used at your own risk! Take the necessary steps to check, validate ...(you are responsible for your choices and actions)
Go to the top of the page
 
aggiemarine07
post Sep 4 2019, 11:23 AM
Post#11



Posts: 75
Joined: 7-January 11



@arnelgp thanks for the adjustments that I needed to make but now Access is freezing when I run the script do you think it has something to do with that @DanielPineault was talking about? Do I just need to re-write this with FSO? If so how would I go about doing that? Thanks.
Go to the top of the page
 
arnelgp
post Sep 4 2019, 12:49 PM
Post#12



Posts: 1,510
Joined: 2-April 09
From: somewhere out there...


here is the rework:
CODE
Sub Command0_Click()
Dim xl As Excel.Application
Dim wbMaster As Excel.Workbook
Set xl = New Excel.Application
Set wbMaster = xl.Workbooks.Open(CurrentProject.Path & "\ProjectBabelfish")

Dim wsCopy As Excel.Worksheet
Set wsCopy = wbMaster.Worksheets("Babelfish")

Dim sFolderPath As String
sFolderPath = wbMaster.Path & "\PLOGs\"
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"

Dim sFileName As String
'--start agp
Dim sh As Worksheet
Dim cFiles As New Collection
Dim i As Integer
sFileName = Dir(sFolderPath & "*.xlsx")
While sFileName <> ""
    cFiles.Add sFileName
    sFileName = Dir
Wend
'--end agp

Dim StrFile As String: StrFile = CurrentProject.Path & "\PLOGs\*.xlsb"

'Disable screenupdating (to prevent "screen flickering" so macro runs smoother)
'Disable alerts (to suppress "Are you sure?" prompts during worksheet deletion)
xl.ScreenUpdating = False
xl.DisplayAlerts = False

On Error Resume Next
If Len(Dir$(StrFile)) > 0 Then
    SetAttr StrFile, vbNormal
    Kill StrFile
End If

'Begin loop through files in the folder
'Do While Len(sFileName) > 0
For i = 1 To cFiles.count
    Dim sWBOpenPassword As String
    Dim sWBProtectPassword As String
    '--agp
    sFileName = cFiles(i)
    '--end agp
    Select Case sFileName
        'Specify workbook names that require passwords here
        Case "book1.xlsx"
            sWBOpenPassword = "550"
            sWBProtectPassword = "550"

        'If different books require different passwords, can specify additional names with their unique passwords
        Case "Book3.xlsx"
            sWBOpenPassword = "book3openpassword"
            sWBProtectPassword = "book3protectionpassword"

        'Keep specifying excel file names and their passwords until completed
        Case "Book10.xlsx", "Book257.xlsx"
            sWBOpenPassword = "GenericOpenPW2"
            sWBProtectPassword = "GenericProtectPW2"

        'Case Else will handle the remaining workbooks that don't require passwords
        Case Else
            'MsgBox sFileName & " has a wierd password"
            sWBOpenPassword = "550"
            sWBProtectPassword = "550"

    End Select

    'Open file using password (if any)
    On Error Resume Next
    With xl.Workbooks.Open(sFolderPath & sFileName, UpdateLinks:=False, Password:=sWBOpenPassword)
        If Err.Number = 1004 Then MsgBox "The workbook " & sFileName & " is at a middle school dance."
        Dim bProtectedWB As Boolean
        bProtectedWB = False    'Reset protected wb check to false

        If .ProtectStructure = True Then bProtectedWB = True 'Check if workbook is protected and if so unprotect it using the specified protection password
        If bProtectedWB = True Then .Unprotect sWBProtectPassword
            
        .Sheets(1).Name = "Whole Foods Market PLOG"
        'MsgBox "Name of Sheets: " & .Sheets(1).Name & ", " & .Sheets(2).Name & ", " & .Sheets(3).Name
        If .Worksheets("Whole Foods Market PLOG").Range("A20") = "" Then
                .Sheets(1).Delete
                .Sheets(1).Name = "Whole Foods Market PLOG"
        End If
            
        On Error Resume Next    'Suppress error if copied worksheet does not yet exist
        .Worksheets(wsCopy.Name).Delete 'Delete existing sheet if it exists
        On Error GoTo 0         'Remove "On Error Resume Next" condition
    
            wsCopy.Copy After:=.Worksheets(.Worksheets.count)   'Copy template into the workbook
            .Worksheets(wsCopy.Name).Cells.Replace wbMaster.Name, .Name 'Change references from master workbook to current workbook
                        
            .Worksheets("Babelfish").Activate
            .Worksheets("Babelfish").Range("A2:Y2").Select
            .Worksheets("Babelfish").Range("A2:Y2").Copy
            .Worksheets("Babelfish").Range("A2:Y2").PasteSpecial Paste:=xlPasteValues
            .Worksheets("Babelfish").Range("AA2:AE201").Select
            .Worksheets("Babelfish").Range("AA2:AE201").Copy
            .Worksheets("Babelfish").Range("AA2:AE201").PasteSpecial Paste:=xlPasteValues
            .Worksheets("Babelfish").Range("AH2:CK201").Select
            .Worksheets("Babelfish").Range("AH2:CK201").Copy
            .Worksheets("Babelfish").Range("AH2:CK201").PasteSpecial Paste:=xlPasteValues
            
            .Sheets(2).Name = "WFM PLOG"
            
'---> This is where I want to delete all excess worksheets
            '--agp start
            For Each sh In .Worksheets
                If LCase(sh.Name) = "wfm plog" Then
                    sh.Delete
                End If
            Next sh
            '--agp end
            
            'If Len(.Sheets(9).Name) > 0 Then
            ''    If .Sheets(9).Name <> "WFM PLOG" Then .Sheets(9).Delete
            '    Else: Resume Next
            '    End If
            'If Len(.Sheets(8).Name) > 0 Then
            '    If .Sheets(8).Name <> "WFM PLOG" Then .Sheets(8).Delete
            '    Else: Resume Next
            '    End If
            'If Len(.Sheets(7).Name) > 0 Then
            '    If .Sheets(7).Name <> "WFM PLOG" Then .Sheets(7).Delete
            '    Else: Resume Next
            '    End If
            'If Len(.Sheets(6).Name) > 0 Then
            '    If .Sheets(6).Name <> "WFM PLOG" Then .Sheets(6).Delete
            '    Else: Resume Next
            '    End If
            'If Len(.Sheets(5).Name) > 0 Then
            '    If .Sheets(5).Name <> "WFM PLOG" Then .Sheets(5).Delete
            '    Else: Resume Next
            '    End If
            'If Len(.Sheets(4).Name) > 0 Then
            ''    If .Sheets(4).Name <> "WFM PLOG" Then .Sheets(4).Delete
            '    Else: Resume Next
            '    End If
            'If Len(.Sheets(3).Name) > 0 Then
            '    If .Sheets(3).Name <> "WFM PLOG" Then .Sheets(3).Delete
            '    Else: Resume Next
            '    End If
            'If Len(.Sheets(2).Name) > 0 Then
            '    If .Sheets(2).Name <> "WFM PLOG" Then .Sheets(2).Delete
            '    Else: Resume Next
            '    End If
            'If Len(.Sheets(1).Name) > 0 Then
            '    If .Sheets(1).Name <> "WFM PLOG" Then .Sheets(1).Delete
            '    Else: Resume Next
            '    End If
'--->End of where I want to delete all excess worksheets
                                                    
            If bProtectedWB = True Then .Protect sWBProtectPassword   'If workbook was protected, reprotect it with same protection password
        '--agp start
                ' we are already using i variable for our outer loop
                Dim j As Integer
        If Not IsEmpty(varLinks) Then
            For j = 1 To UBound(varLinks)
                .BreakLink _
                    Name:=varLinks(i), _
                    Type:=xlLinkTypeExcelLinks
            Next j
        End If
        
        .SaveAs FileName:=sFolderPath & Mid(sFileName, 1, Len(sFileName) - 5) & ".xlsb", FileFormat:=xlExcel12, CreateBackup:=False
        .Save
        .Close True

    End With
    '--agp start
    'sFileName = Dir 'Advance to next file in the folder
    '--agp end
'Loop
Next i
'Re-enable screenupdating and alerts
xl.ScreenUpdating = True
xl.DisplayAlerts = True
xl.Quit
Set xl = Nothing
MsgBox "Added Tab to all PLOG files"

End Sub

This post has been edited by arnelgp: Sep 4 2019, 12:54 PM

--------------------
Never stop learning, because life never stops teaching.
Go to the top of the page
 
aggiemarine07
post Sep 4 2019, 02:01 PM
Post#13



Posts: 75
Joined: 7-January 11



@arnelgp wow! thanks for all that hard work! When I put copy/pasted that into Access, it runs successfully but doesnt delete the spreadsheets; any idea why?

edit: its also prompting me to if I want to save the master excel document; do i just need to move the xl.Quit line up?
This post has been edited by aggiemarine07: Sep 4 2019, 02:04 PM
Go to the top of the page
 
DanielPineault
post Sep 4 2019, 02:12 PM
Post#14


UtterAccess VIP
Posts: 7,011
Joined: 30-June 11



You should set a workbook variable, even sheet variables.

CODE
Set xlWrkBk = xl.Workbooks.Open(sFolderPath & sFileName, UpdateLinks:=False, Password:=sWBOpenPassword)


Then either code would work because you'd be driectly binding to the specified workbook
CODE
            For Each sh In xlWrkBk .Worksheets
                If LCase(sh.Name) = "wfm plog" Then
                    sh.Delete
                End If
            Next sh


I'm a little confused by
CODE
            .SaveAs FileName:=sFolderPath & Mid(sFileName, 1, Len(sFileName) - 5) & ".xlsb", FileFormat:=xlExcel12, CreateBackup:=False
            .Save
            .Close True

You're saving it as another file name, then saving it, then closing and saving it yet again?

also
CODE
Set wbMaster = xl.Workbooks.Open(CurrentProject.Path & "\ProjectBabelfish")

no extension specified?

You are specifying On Error Resume Next a couple times in the code, no need, just once. Even at that, you would be better with proper error handling, right now you are ignoring errors, so you might not be getting errors reported back to you explaining why the code isn't working as expected. On Error Resume Next is to be avoid as much as possible.

--------------------
Daniel Pineault (2010-2019 Microsoft MVP, UA VIP, EE Distinguished Expert 2018)
Professional Help: https://www.cardaconsultants.com
Free MS Access Code, Tips, Tricks and Samples: https://www.devhut.net

* Design should never say "Look at me". It should always say "Look at this". -- David Craib
* A user interface is like a joke, if you have to explain it, it's not that good! -- Martin LeBlanc


All code samples, demonstration databases, links,... are provided 'AS IS' and are to be used at your own risk! Take the necessary steps to check, validate ...(you are responsible for your choices and actions)
Go to the top of the page
 
aggiemarine07
post Sep 4 2019, 04:32 PM
Post#15



Posts: 75
Joined: 7-January 11



@DanielPineault Those last two questions you posted were just simple errors on my part, probably from staring at this code much these last few days smile.gif

I made the suggested edits from the front half of your post but it still does not remove the worksheets not labeled "WFM PLOG". I feel like im missing something stupid/insignificant :-/

Here is the revised code:

CODE
Sub Command0_Click()
Dim xl As Excel.Application
Dim wbMaster As Excel.Workbook
Set xl = New Excel.Application
Set wbMaster = xl.Workbooks.Open(CurrentProject.path & "\ProjectBabelfish.xlsb")

Dim wsCopy As Excel.Worksheet
Set wsCopy = wbMaster.Worksheets("Babelfish")

Dim sFolderPath As String
sFolderPath = wbMaster.path & "\PLOGs\"
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"

Dim sFileName As String
'--start agp
Dim sh As Worksheet
Dim cFiles As New Collection
Dim i As Integer
sFileName = Dir(sFolderPath & "*.xlsx")
While sFileName <> ""
    cFiles.Add sFileName
    sFileName = Dir
Wend
'--end agp

Dim StrFile As String: StrFile = CurrentProject.path & "\PLOGs\*.xlsb"

'Disable screenupdating (to prevent "screen flickering" so macro runs smoother)
'Disable alerts (to suppress "Are you sure?" prompts during worksheet deletion)
xl.ScreenUpdating = False
xl.DisplayAlerts = False

On Error Resume Next
If Len(Dir$(StrFile)) > 0 Then
    SetAttr StrFile, vbNormal
    Kill StrFile
End If

'Begin loop through files in the folder
'Do While Len(sFileName) > 0
For i = 1 To cFiles.Count
    Dim sWBOpenPassword As String
    Dim sWBProtectPassword As String
    '--agp
    sFileName = cFiles(i)
    '--end agp
    Select Case sFileName
        'Specify workbook names that require passwords here
        Case "book1.xlsx"
            sWBOpenPassword = "550"
            sWBProtectPassword = "550"

        'If different books require different passwords, can specify additional names with their unique passwords
        Case "Book3.xlsx"
            sWBOpenPassword = "book3openpassword"
            sWBProtectPassword = "book3protectionpassword"

        'Keep specifying excel file names and their passwords until completed
        Case "Book10.xlsx", "Book257.xlsx"
            sWBOpenPassword = "GenericOpenPW2"
            sWBProtectPassword = "GenericProtectPW2"

        'Case Else will handle the remaining workbooks that don't require passwords
        Case Else
            'MsgBox sFileName & " has a wierd password"
            sWBOpenPassword = "550"
            sWBProtectPassword = "550"

    End Select

    'Open file using password (if any)
    On Error Resume Next
    With xl.Workbooks.Open(sFolderPath & sFileName, UpdateLinks:=False, Password:=sWBOpenPassword)
        If Err.Number = 1004 Then MsgBox "The workbook " & sFileName & " is at a middle school dance."
        Dim bProtectedWB As Boolean
        bProtectedWB = False    'Reset protected wb check to false

        If .ProtectStructure = True Then bProtectedWB = True 'Check if workbook is protected and if so unprotect it using the specified protection password
        If bProtectedWB = True Then .Unprotect sWBProtectPassword
            
        .Sheets(1).Name = "Whole Foods Market PLOG"
        'MsgBox "Name of Sheets: " & .Sheets(1).Name & ", " & .Sheets(2).Name & ", " & .Sheets(3).Name
        If .Worksheets("Whole Foods Market PLOG").Range("A20") = "" Then
                .Sheets(1).Delete
                .Sheets(1).Name = "Whole Foods Market PLOG"
        End If
            
        On Error Resume Next    'Suppress error if copied worksheet does not yet exist
        .Worksheets(wsCopy.Name).Delete 'Delete existing sheet if it exists
        On Error GoTo 0         'Remove "On Error Resume Next" condition
    
            wsCopy.Copy After:=.Worksheets(.Worksheets.Count)   'Copy template into the workbook
            .Worksheets(wsCopy.Name).Cells.Replace wbMaster.Name, .Name 'Change references from master workbook to current workbook
                        
            .Worksheets("Babelfish").Activate
            .Worksheets("Babelfish").Range("A2:Y2").Select
            .Worksheets("Babelfish").Range("A2:Y2").Copy
            .Worksheets("Babelfish").Range("A2:Y2").PasteSpecial Paste:=xlPasteValues
            .Worksheets("Babelfish").Range("AA2:AE201").Select
            .Worksheets("Babelfish").Range("AA2:AE201").Copy
            .Worksheets("Babelfish").Range("AA2:AE201").PasteSpecial Paste:=xlPasteValues
            .Worksheets("Babelfish").Range("AH2:CK201").Select
            .Worksheets("Babelfish").Range("AH2:CK201").Copy
            .Worksheets("Babelfish").Range("AH2:CK201").PasteSpecial Paste:=xlPasteValues
            
            .Sheets(2).Name = "WFM PLOG"
            
            Set xlWrkBk = xl.Workbooks.Open(sFolderPath & sFileName, UpdateLinks:=False, Password:=sWBOpenPassword)
            
            For Each sh In xlWrkBk.Worksheets
                If LCase(sh.Name) = "wfm plog" Then
                    sh.Delete
                End If
            Next sh
                                                                
            If bProtectedWB = True Then .Protect sWBProtectPassword   'If workbook was protected, reprotect it with same protection password
        '--agp start
                ' we are already using i variable for our outer loop
                Dim j As Integer
        If Not IsEmpty(varLinks) Then
            For j = 1 To UBound(varLinks)
                .BreakLink _
                    Name:=varLinks(i), _
                    Type:=xlLinkTypeExcelLinks
            Next j
        End If
        
        .SaveAs FileName:=sFolderPath & Mid(sFileName, 1, Len(sFileName) - 5) & ".xlsb", FileFormat:=xlExcel12, CreateBackup:=False
        .Close True

    End With
Next i
'Re-enable screenupdating and alerts
xl.ScreenUpdating = True
xl.DisplayAlerts = True
xl.Quit
Set xl = Nothing
MsgBox "Added Tab to all PLOG files"

End Sub
Go to the top of the page
 
MadPiet
post Sep 4 2019, 05:50 PM
Post#16



Posts: 3,367
Joined: 27-February 09



Not sure what you're doing wrong. (Are you saving the files after making the changes?)

This worked to delete the sheets that don't start with the prefix "wfm plog"

CODE
    Dim sht As Worksheet
    For Each sht In ActiveWorkbook.Sheets
        If Left$(sht.Name, 8) <> "wfm plog" Then
            sht.Delete
        End If
    Next sht

But if you don't save the workbook after doing this, you're not saving the changes.
Go to the top of the page
 
arnelgp
post Sep 4 2019, 10:35 PM
Post#17



Posts: 1,510
Joined: 2-April 09
From: somewhere out there...


CODE
Sub Command0_Click()
Dim xl As Excel.Application
Dim wbMaster As Excel.Workbook
Dim xlWrkBk As Excel.Workbook

Set xl = New Excel.Application
Set wbMaster = xl.Workbooks.Open(CurrentProject.Path & "\ProjectBabelfish.xlsb")

Dim wsCopy As Excel.Worksheet
Set wsCopy = wbMaster.Worksheets("Babelfish")

Dim sFolderPath As String
sFolderPath = wbMaster.Path & "\PLOGs\"
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"

Dim sFileName As String
'--start agp
Dim sh As Worksheet
Dim cFiles As New Collection
Dim i As Integer
sFileName = Dir(sFolderPath & "*.xlsx")
While sFileName <> ""
    cFiles.Add sFileName
    sFileName = Dir
Wend
'--end agp

Dim StrFile As String: StrFile = CurrentProject.Path & "\PLOGs\*.xlsb"

'Disable screenupdating (to prevent "screen flickering" so macro runs smoother)
'Disable alerts (to suppress "Are you sure?" prompts during worksheet deletion)
xl.ScreenUpdating = False
xl.DisplayAlerts = False

On Error Resume Next
If Len(Dir$(StrFile)) > 0 Then
    SetAttr StrFile, vbNormal
    Kill StrFile
End If

'Begin loop through files in the folder
'Do While Len(sFileName) > 0
For i = 1 To cFiles.Count
    Dim sWBOpenPassword As String
    Dim sWBProtectPassword As String
    '--agp
    sFileName = cFiles(i)
    '--end agp
    Select Case sFileName
        'Specify workbook names that require passwords here
        Case "book1.xlsx"
            sWBOpenPassword = "550"
            sWBProtectPassword = "550"
        
        'If different books require different passwords, can specify additional names with their unique passwords
        Case "Book3.xlsx"
            sWBOpenPassword = "book3openpassword"
            sWBProtectPassword = "book3protectionpassword"
        
        'Keep specifying excel file names and their passwords until completed
        Case "Book10.xlsx", "Book257.xlsx"
            sWBOpenPassword = "GenericOpenPW2"
            sWBProtectPassword = "GenericProtectPW2"
        
        'Case Else will handle the remaining workbooks that don't require passwords
        Case Else
            'MsgBox sFileName & " has a wierd password"
            sWBOpenPassword = "550"
            sWBProtectPassword = "550"
        
    End Select
    
    'Open file using password (if any)
    On Error Resume Next
    Set xlWrkBk = xl.Workbooks.Open(sFolderPath & sFileName, UpdateLinks:=False, Password:=sWBOpenPassword)
    If Err.Number = 1004 Then
        MsgBox "The workbook " & sFileName & " is at a middle school dance."
    Else
        With xlWrkBk
            Dim bProtectedWB As Boolean
            bProtectedWB = False    'Reset protected wb check to false
            
            If .ProtectStructure = True Then bProtectedWB = True 'Check if workbook is protected and if so unprotect it using the specified protection password
            If bProtectedWB = True Then .Unprotect sWBProtectPassword
            
            .Sheets(1).Name = "Whole Foods Market PLOG"
            'MsgBox "Name of Sheets: " & .Sheets(1).Name & ", " & .Sheets(2).Name & ", " & .Sheets(3).Name
            If .Worksheets("Whole Foods Market PLOG").Range("A20") = "" Then
                .Sheets(1).Delete
                .Sheets(1).Name = "Whole Foods Market PLOG"
            End If
            
            On Error Resume Next    'Suppress error if copied worksheet does not yet exist
            .Worksheets(wsCopy.Name).Delete 'Delete existing sheet if it exists
            On Error GoTo 0         'Remove "On Error Resume Next" condition
            
            wsCopy.Copy After:=.Worksheets(.Worksheets.Count)   'Copy template into the workbook
            .Worksheets(wsCopy.Name).Cells.Replace wbMaster.Name, .Name 'Change references from master workbook to current workbook
            
            .Worksheets("Babelfish").Activate
            .Worksheets("Babelfish").Range("A2:Y2").Select
            .Worksheets("Babelfish").Range("A2:Y2").Copy
            .Worksheets("Babelfish").Range("A2:Y2").PasteSpecial Paste:=xlPasteValues
            .Worksheets("Babelfish").Range("AA2:AE201").Select
            .Worksheets("Babelfish").Range("AA2:AE201").Copy
            .Worksheets("Babelfish").Range("AA2:AE201").PasteSpecial Paste:=xlPasteValues
            .Worksheets("Babelfish").Range("AH2:CK201").Select
            .Worksheets("Babelfish").Range("AH2:CK201").Copy
            .Worksheets("Babelfish").Range("AH2:CK201").PasteSpecial Paste:=xlPasteValues
            
            .Sheets(2).Name = "WFM PLOG"
            
            Dim j As Integer
            For j = .Worksheets.Count To 1 Step -1
                If Trim(LCase(.Worksheets(j).Name)) = "wfm plog" Then
                    .Worksheets(j).Delete
                End If
            Next j
                                
            If bProtectedWB = True Then .Protect sWBProtectPassword   'If workbook was protected, reprotect it with same protection password
            '--agp start
            ' we are already using i variable for our outer loop
            If Not IsEmpty(varLinks) Then
                For j = 1 To UBound(varLinks)
                    .BreakLink _
                    Name:=varLinks(i), _
                    Type:=xlLinkTypeExcelLinks
                    Next j
            End If
            
            .SaveAs Filename:=sFolderPath & Mid(sFileName, 1, Len(sFileName) - 5) & ".xlsb", FileFormat:=xlExcel12, CreateBackup:=False
            .Close True
                
        End With
    End If
Next i
'Re-enable screenupdating and alerts
xl.ScreenUpdating = True
xl.DisplayAlerts = True
xl.Quit
Set xl = Nothing
MsgBox "Added Tab to all PLOG files"
    
End Sub

--------------------
Never stop learning, because life never stops teaching.
Go to the top of the page
 
aggiemarine07
post Sep 5 2019, 07:53 AM
Post#18



Posts: 75
Joined: 7-January 11



@arnelgp and @MadPiet I was able to resolve it by combing stuff from both of your posts. I changed the Object at the top from:

CODE
Dim sh As Worksheet

To
CODE
Dim sht As Worksheet


And I also changed this:

CODE
Dim j As Integer
For j = .Worksheets.Count To 1 Step -1
   If Trim(LCase(.Worksheets(j).Name)) = "wfm plog" Then
      .Worksheets(j).Delete
End If
Next j


To this:
CODE
Dim j As Integer
xl.ScreenUpdating = False
xl.DisplayAlerts = False
For j = .Worksheets.Count To 1 Step -1
   If .Worksheets(j).Name <> "WFM PLOG" Then
   .Worksheets(j).Delete
   .SaveAs FileName:=sFolderPath & Mid(sFileName, 1, Len(sFileName) - 5) & ".xlsb", FileFormat:=xlExcel12, CreateBackup:=False
End If
Next j


And now it does exactly as I originally intended, thank you so much for all of your help and expertise!
Go to the top of the page
 


Custom Search


RSSSearch   Top   Lo-Fi    12th December 2019 - 09:12 PM