Question

我正在为我的工作组中的每个人创建一个数据文件。数据文件需要与主文件相同，因为每个人数据将被收集到所述主文件以及单个数据文件中。

到目前为止，我有以下代码，我尝试确定用户是否已有工作簿。我希望创建的工作簿与主工作簿具有相同的前四页。

指定的文件夹只包含“DataFile Master”工作簿，因此我不希望宏花费的时间超过~5秒。但是，当我尝试运行宏时，工作簿变得无法响应。

程序不会引发错误报告或指示要调试的内容。

有没有人有任何想法？

 Sub StoreToPersonal()
    Application.ScreenUpdating = False
    ckIndWkbk = False
    folderpath = "\\netappa\Path\MACRO UPDATE WORKBOOKS" 'change to suit

    If Right(folderpath, 1) <> "\" Then folderpath = folderpath + "\"

    filename = Dir(folderpath & "*.xlsm")
    'Look through path length and find if user has an individual Workbook with a Boolean Statement

    Do While filename <> ""
      If InStr(filename, Environ("Username")) Then
        ckIndWkbk = True
      Else
    End If

    Loop

       If ckIndWkbk = False Then
            Set wb = Workbooks.Open("\\netappa\Path\MACRO UPDATE WORKBOOKS\DataFile Master.xlsm")
                ws = wb.Sheets.Count
                    For Each ws In wb
                        If ws.Index > 4 Then
                            Application.DisplayAlerts = False
                                ws.Delete
                            Application.DisplayAlerts = True
                        End If
                    Next ws

            wb.SaveAs ("\\netappa\Path\MACRO UPDATE WORKBOOKS\\DataFile For " & Environ("Username"))

        End If

Application.ScreenUpdating = True

End Sub

Answer 1

第一个Dir调用设置参数并返回目录中的第一个文件。您需要使用Dir中的Do Loop来返回后续文件。

注意：我在满足条件后添加了Exit Do。

MSDN Dir Function

Sub StoreToPersonal()
    Application.ScreenUpdating = False
    ckIndWkbk = False
    folderpath = "\\netappa\Path\MACRO UPDATE WORKBOOKS"    'change to suit

    If Right(folderpath, 1) <> "\" Then folderpath = folderpath + "\"

    Filename = Dir(folderpath & "*.xlsm")
    'Look through path length and find if user has an individual Workbook with a Boolean Statement

    Do While Filename <> ""
        If InStr(Filename, Environ("Username")) Then
            ckIndWkbk = True
            Exit Do
        End If
        Filename = Dir
    Loop

    If ckIndWkbk = False Then
        Set wb = Workbooks.Open("\\netappa\Path\MACRO UPDATE WORKBOOKS\DataFile Master.xlsm")
        ws = wb.Sheets.Count
        For Each ws In wb
            If ws.Index > 4 Then
                Application.DisplayAlerts = False
                ws.Delete
                Application.DisplayAlerts = True
            End If
        Next ws

        wb.SaveAs ("\\netappa\Path\MACRO UPDATE WORKBOOKS\\DataFile For " & Environ("Username"))

    End If

    Application.ScreenUpdating = True

End Sub

查找是否存在单个用户的工作簿，如果工作簿不存在，请使用模板

1 个答案: