找到，如果工作簿个别用户存在，如果工作簿不存在，创建模板

Question

一个新的工作簿我有我试图让每个人对我的工作组的数据文件。数据文件需要与主文件相同，因为每个人数据将被收集到所述主文件以及单个数据文件中。

到目前为止，我有以下的代码，我试图找出用户是否已经有一个工作簿。我希望创建的工作簿与主工作簿具有相同的前四张。

指定的文件夹只包含了“数据文件大师”工作簿，所以我不希望宏时间比约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