Question

我们有一个共享文件夹，用户可以在其中打开Excel工作簿，填写数据，然后运行创建子文件夹的宏，并将工作簿的版本复制到该文件夹中。子文件夹和新工作簿根据输入表单的数据命名。

将来某个时候会打开新工作簿，进行修订并在子文件夹中创建工作簿的新版本（带有修订名称）。冲洗并重复。这太可怕了。

这些自我复制的borg excel电子表格很容易存在。最大的磨擦？宏的根路径的硬编码路径。现在必须移动根文件夹。

我自己不是一个优秀的用户，但我需要解决这个问题。有什么东西我可以用.Net（或其他任何东西）来写一些根源＆amp;子文件夹，并更新它找到的每个Excel文件以更改路径？当然，所有这些都不会损害每个电子表格中的数据？！

任何帮助表示赞赏。

编辑:(所以你不需要挖掘评论） @brettdj的以下解决方案开箱即用。对于我的情况，我确实将其移出Sub Main()，我需要从他的示例中更改以下行：

bFound = .Find("C:\test\xxx", SL, SC, EL, EC, True, False, False)

到

bFound = .Find("C:\test\xxx", SL, SC, EL, EC, False, False, False)

我相信这会改变查找不匹配整个单词。

我还有一个VBA项目受密码保护的问题，我目前尚未解决，但@brettdj建议this possible solution。

编辑2：VBA项目密码解决方案有效！我还将@brettdj代码示例移动到了一个vb.net项目中，现在循环遍历超过400k的所有文件，检查是否需要密码，如果是，请将其解锁，搜索代码以查找有问题的行，如果找到则替换它，然后保存，如果修改。总的来说，酷豆。

Answer 1

VBA解决方案

此代码在strStartFolder = "c:\temp"

recursive Dir

打开所有Excel文件，然后使用Pearson's method识别并替换四种代码模块类型中的某个字符串：
"c:\temp\xxx"
与
"d:\temp\yyy"
代码然后保存调整后的工作簿（但只是关闭未经修改的工作簿）
然后向用户提供所做更改的摘要文件

编写VBE的一个特性是使用字符串变量失败：
bFound = .Find(strOld, SL, SC, EL, EC, True, False, False)
我不得不硬编码字符串来代替 bFound = .Find("c:\temp\xxx", SL, SC, EL, EC, True, False, False)

enter image description here

 Option Explicit

Public StrArray()
Public lngCnt As Long

Public Sub Main()
    Dim objFSO As Object
    Dim objFolder As Object
    Dim WB As Workbook
    Dim ws As Worksheet
    Dim strStartFolder As String

     'Setup Application for the user
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

     'reset public variables
    lngCnt = 0
    ReDim StrArray(1 To 4, 1 To 1000)

    strStartFolder = "c:\temp"
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(strStartFolder)

     ' Format output sheet
    Set WB = Workbooks.Add(1)
    Set ws = WB.Worksheets(1)
    ws.[a1] = Now()
    ws.[a2] = strStartFolder
    ws.[a1:a3].HorizontalAlignment = xlLeft

    ws.[A4:D4].Value = Array("Folder", "File", "Code Module", "line")
    ws.Range([a1], [c4]).Font.Bold = True
    ws.Rows(5).Select
    ActiveWindow.FreezePanes = True


     ' Start the code to gather the files
    ShowSubFolders objFolder, True
    ShowSubFolders objFolder, False

    If lngCnt > 0 Then
         ' Finalise output
        With ws.Range(ws.[a5], ws.Cells(5 + lngCnt - 1, 4))
            .Value2 = Application.Transpose(StrArray)
            .Offset(-1, 0).Resize(Rows.Count - 3, 4).AutoFilter
            .Offset(-4, 0).Resize(Rows.Count, 4).Columns.AutoFit
        End With
        ws.[a1].Activate
    Else
        MsgBox "No files found!", vbCritical
        WB.Close False
    End If

     ' tidy up

    Set objFSO = Nothing

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .StatusBar = vbNullString
    End With
End Sub


Sub ShowSubFolders(ByVal objFolder, bRootFolder As Boolean)

    Dim colFolders As Object
    Dim objSubfolder As Object
    Dim WB As Workbook
    Dim strOld As String
    Dim strNew As String
    Dim strFname As String

    Dim VBProj As Object
    Dim VBComp As Object
    Dim CodeMod As Object
    Dim bFound As Boolean
    Dim bWBFound As Boolean

    Dim SL As Long
    Dim SC As Long
    Dim EL As Long
    Dim EC As Long
    Dim S As String


    strOld = "c:\temp\xxx"
    strNew = "D:\temp\yyy"

    Set colFolders = objFolder.SubFolders
    Application.StatusBar = "Processing " & objFolder.Path

    If bRootFolder Then
        Set objSubfolder = objFolder
        GoTo OneTimeRoot
    End If

    For Each objSubfolder In colFolders
         'check to see if root directory files are to be processed
OneTimeRoot:
        strFname = Dir(objSubfolder.Path & "\*.xls*")
        Do While Len(strFname) > 0
            Set WB = Workbooks.Open(objSubfolder.Path & "\" & strFname, False)
            Set VBProj = WB.VBProject
            For Each VBComp In VBProj.vbcomponents
                    Set CodeMod = VBComp.CodeModule
                    With CodeMod
                        SL = 1
                        EL = .CountOfLines
                        SC = 1
                        EC = 255
                        bFound = .Find("C:\test\xxx", SL, SC, EL, EC, True, False, False)
                         'bFound = .Find(strOld, SL, SC, EL, EC, True, False, False)
                        If bFound Then bWBFound = True
                        Do Until bFound = False
                            lngCnt = lngCnt + 1
                            If UBound(StrArray, 2) Mod 1000 = 0 Then ReDim Preserve StrArray(1 To 4, 1 To UBound(StrArray, 2) + 1000)
                            StrArray(1, lngCnt) = objSubfolder.Path
                            StrArray(2, lngCnt) = WB.Name
                            StrArray(3, lngCnt) = CodeMod.Name
                            StrArray(4, lngCnt) = SL
                            EL = .CountOfLines
                            SC = EC + 1
                            EC = 255
                            S = .Lines(SL, 1)
                            S = Replace(S, "C:\test\xxx", "D:\test\yyy")
                            .ReplaceLine SL, S
                            bFound = .Find("C:\test\xxx", SL, SC, EL, EC, True, False, False)
                        Loop
                    End With
            Next
            If bWBFound Then WB.Save
            WB.Close False
            strFname = Dir
        Loop
        If bRootFolder Then
            bRootFolder = False
            Exit Sub
        End If
        ShowSubFolders objSubfolder, False
    Next
End Sub

如何在数百个excel文件中更新宏？

1 个答案: