Question

我编写的代码需要执行以下操作：

扫描目录op.xlsx文件＃请检查
打开文件激活页“ Buitendelen”（某些文件没有跳过文件，然后继续）
如果已激活工作表“ buitendelen”，请在C和D之间添加新列
保存文件
关闭文件
转到下一个文件

有时它不起作用，或者在编辑文件一段时间后崩溃。

Sub AllFiles_click()
    '//Change the path to the main folder, accordingly
    Call RecursiveFolders("C:\testlab\testmap")
End Sub

Sub RecursiveFolders(ByVal MyPath As String)

    Dim FileSys As Object
    Dim objFolder As Object
    Dim objSubFolder As Object
    Dim objFile As Object
    Dim wkbOpen As Workbook

    Set FileSys = CreateObject("Scripting.FileSystemObject")
    Set objFolder = FileSys.GetFolder(MyPath)

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    'open every folder and subfolder
    For Each objSubFolder In objFolder.SubFolders

        'search for file in folder and subfolder
        For Each objFile In objSubFolder.Files

            'set open workbook
            Set wkbOpen = Workbooks.Open(filename:=objFile)

            'call passwordfirst code to unlock sheets
            Call passwordfirst

            'activated sheet buitendelen
            wkbOpen.Sheets("Buitendelen").Activate

            'call columnadd code to add column
            Call columnadd

            'close workbook and save
            wkbOpen.Close savechanges:=True
        Next

        'start over again
        Call RecursiveFolders(objSubFolder.Path)

    Next

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

'code to unlock sheets with password
Sub passwordfirst()
    ActiveSheet.Unprotect Password:="Freonr410a"
End Sub

'code to add column
Private Sub columnadd()
    Columns("D:D").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub

Answer 1

我看到了一些有关您的代码和问题的信息。首先，行：

ActiveSheet.Unprotect Password:="Freonr410a"

此行有时可能会引起一些问题，因为在打开特定工作簿后，您的第一个活动工作表可能不是 Buitendelen 工作表。您正在依靠某人（或您自己）关闭此工作表处于活动状态的工作簿（不可靠的事情）。

此行：

Columns("D:D").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

...如果要添加新列，也可能是某些问题的根源。图像您的第一个工作表不是 Buitendele 工作表。您可以成功解锁不受保护的工作表，但是现在您尝试将新列添加到完全不同的工作表中。不可接受。

我还看到您省略了根文件夹（“ C：\ testlab \ testmap”）中的任何文件（文件夹除外）。这意味着，如果您在TestMap文件夹中有任何文件，它们将保持不变。我不知道这是否是所需要的。

在这里，您可以找到解决问题的方法（在W10 / Excel 2017 32位上进行了测试）

Sub AllFiles_click()
    Call RecursiveFolders("C:\testlab\testmap")
End Sub

' Go through every folder starting from objFolder
' location recursively and add one column after column D
' inside workbook. If Buitendelen worksheet does not exists,
' go to next workbook.
Sub RecursiveFolders(ByVal MyPath As String)
    Const BuitendelenWsName as String = "Buitendelen"

    Dim FileSys As Object
    Dim objFolder As Object
    Dim objSubFolder As Object
    Dim objFile As Object
    Dim wkbOpen As Workbook
    Dim wshToEdit as Worksheet

    Set FileSys = CreateObject("Scripting.FileSystemObject")
    Set objFolder = FileSys.GetFolder(MyPath)

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    For Each objSubFolder In objFolder.SubFolders
        For Each objFile In objSubFolder.Files
            Set wkbOpen = Workbooks.Open(filename:=objFile)

            If SheetExists(BuitendelenWsName, wkbOpen) Then
                Set wshToEdit = wkbOpen.Worksheets(BuitendelenWsName)

                ' Before any changes, worksheet has to be unprotected.
                wshToEdit.Unprotect Password:="Freonr410a"
                wshToEdit.Columns("D:D").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
            End if

            wkbOpen.Close savechanges:=True
        Next
        Call RecursiveFolders(objSubFolder.Path)
    Next

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    set FileSys = nothing
    set objFolder = nothing
    set objSubFolder = nothing
    set objFile = nothing
    set wkbOpen = nothing
    set wshToEdit = nothing
End Sub

Public Function SheetExists(byval sheetToFind As String, byref container as Workbook) As Boolean
    Dim sht as Worksheet

    SheetExists = False
    For Each sht In container.Worksheets
        If sheetToFind = sht.name Then
            SheetExists = True
            Exit For
        End If
    Next sht 

    set sht = nothing
End Function

附加说明：请按照您的命名约定进行操作，AllFiles或RecursiveFolders不会告诉您有关子例程主体的信息。

变量命名约定：准确的说，如果要使用匈牙利表示法，请使用它-FileSys应该更改为objFileSys。

遍历目录打开每个文件激活工作表并添加新列

1 个答案: