VBA如果找不到文件创build和粘贴数据

我希望你能帮上忙。 我有一段代码，看代码1（我的代码完整），本质上是它允许用户浏览文件夹，select一个文件。 一旦选定，它将基于A列中的标准（国家）的工作簿分成新的工作表，在国家之后重新命名新的工作表并添加一些文本。 所有这一切正常。

我面临的问题是，当工作簿被拆分成不同的工作表。 请参阅图1，然后我需要将特定的国家/地区表复制并粘贴到已存储在其他文件夹中的工作簿中。 请参阅图2.如果工作簿已经存在于文件夹中（在我的德国例子中），但是如果工作簿不存在（比利时），我的代码工作正常，我需要代码为该国家创build一个新的工作簿，然后粘贴数据导入新的工作簿。

因此，在图2中，您可以看到德国文件夹H:\TOV Storage Folder ，复制和粘贴代码见代码2工作正常

代码2

 If s.Name = "DE_ITOV_MTNG_ATNDEE.xlsx" Then s.Activate ActiveSheet.Range("A1", ActiveCell.SpecialCells(xlLastCell)).Copy Set y = Workbooks.Open("H:\TOV Storage Folder\Germany.xlsx") y.Sheets(2).Name = "DE_ITOV_MTNG_ATNDEE" y.Sheets("DE_ITOV_MTNG_ATNDEE").Range("A1").PasteSpecial Paste:=xlPasteFormulas y.SaveAs "H:\TOV Storage Folder\Germany.xlsx" y.Close 

但比利时不存在于文件夹H:\TOV Storage Folder所以代码3抛出一个错误说，在H:\TOV Storage Folder找不到比利时，macros停止

代码3

 ElseIf s.Name = "BE_ITOV_MTNG_ATNDEE.xlsx" Then s.Activate ActiveSheet.Range("A1", ActiveCell.SpecialCells(xlLastCell)).Copy Set y_1 = Workbooks.Open("H:\TOV Storage Folder\Belgium.xlsx") y_1.Sheets(2).Name = "BE_ITOV_MTNG_ATNDEE" y_1.Sheets("BE_ITOV_MTNG_ATNDEE").Range("A1").PasteSpecial Paste:=xlPasteFormulas y_1.SaveAs "H:\TOV Storage Folder\Belgium.xlsx" y_1.Close 

实质上，我需要做的是将工作簿分解到其国家/地区表中，然后让macros在H:\TOV Storage Folderfind具有相应工作簿的国家/地区表，然后执行复制如果在H:\TOV Storage Folderfind分割工作簿中没有相应国家/地区的工作表，则创build一个工作簿并执行粘贴，然后移动到分割工作簿中的下一个国家/地区表中并重复处理。

以一种非常简单的方式，我需要macros来search拆分表，然后去“啊，我find了法国FR_ITOV_MTNG_ATNDEE.xlsx，你有一个工作簿在H:\TOV Storage Folder复制，粘贴，下一张，我发现拉脱维亚LV_ITOV_MTNG_ATNDEE .xlsx在H:\TOV Storage Folder工作簿为拉脱维亚创build工作簿，复制，粘贴！等等。

我很抱歉，如果我的问题是漫长的，我只是想让我的问题透明。

我的代码可以修改来解决我的问题吗？

与往常一样，所有的帮助是非常感激的。

代码1

  Sub Make_Macro_Go_now() Dim my_FileName As Variant MsgBox "Pick your TOV file" '<--| txt box for prompt to pick a file my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection If my_FileName <> False Then Workbooks.Open FileName:=my_FileName Call Filter_2 '<--|Calls the Filter Code and executes End If End Sub Public Sub Filter_2() 'Optimize Macro Speed Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual Dim rCountry As Range, helpCol As Range Dim FileName As String Dim s As Worksheet Dim y As Workbook ''AT Dim y_1 As Workbook ''BE FileName = Right(ActiveWorkbook.Name, 22) With ActiveWorkbook.Sheets(1) '<--| refer to data worksheet With .UsedRange Set helpCol = .Resize(1, 1).Offset(, .Columns.Count) '<--| get a "helper" column just at the right of used range, it'll be used to store unique country names in End With With .Range("A1:Q" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--| refer to its columns "A:Q" from row 1 to last non empty row of column "A" .Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=helpCol, Unique:=True '<-- call AdvancedFilter on 6th column of the referenced range and store its unique values in "helper" column Set helpCol = Range(helpCol.Offset(1), helpCol.End(xlDown)) '<--| set range with unique names in (skip header row) For Each rCountry In helpCol '<--| iterate over unique country names range (skip header row) .AutoFilter 1, rCountry.Value2 '<--| filter data on country field (6th column) with current unique country name If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then '<--| if any cell other than header ones has been filtered... Worksheets.Add Worksheets(Worksheets.Count) '<--... add new sheet ActiveSheet.Name = rCountry.Value2 & FileName '<--... rename it .SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1") 'copy data for country under header End If Next End With .AutoFilterMode = False '<--| remove autofilter and show all rows back End With helpCol.Offset(-1).End(xlDown).Clear '<--| clear helper column (header included) ''Copy and Paste Data For Each s In Sheets If s.Name = "DE_ITOV_MTNG_ATNDEE.xlsx" Then s.Activate ActiveSheet.Range("A1", ActiveCell.SpecialCells(xlLastCell)).Copy Set y = Workbooks.Open("H:\TOV Storage Folder\Germany.xlsx") y.Sheets(2).Name = "DE_ITOV_MTNG_ATNDEE" y.Sheets("DE_ITOV_MTNG_ATNDEE").Range("A1").PasteSpecial Paste:=xlPasteFormulas y.SaveAs "H:\TOV Storage Folder\Germany.xlsx" y.Close ElseIf s.Name = "BE_ITOV_MTNG_ATNDEE.xlsx" Then s.Activate ActiveSheet.Range("A1", ActiveCell.SpecialCells(xlLastCell)).Copy Set y_1 = Workbooks.Open("H:\TOV Storage Folder\Belgium.xlsx") y_1.Sheets(2).Name = "BE_ITOV_MTNG_ATNDEE" y_1.Sheets("BE_ITOV_MTNG_ATNDEE").Range("A1").PasteSpecial Paste:=xlPasteFormulas y_1.SaveAs "H:\TOV Storage Folder\Belgium.xlsx" y_1.Close ''Exit Sub End If Next s ''MsgBox "Sheet a does not exist" ''End If 'Message Box when tasks are completed MsgBox "Task Complete!" ResetSettings: 'Reset Macro Optimization Settings Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Public Function DoesFileExist(ByVal sFile) Dim oFSO As New FileSystemObject If oFSO.FileExists(sFile) Then DoesFileExist = True Else DoesFileExist = False End If End Function 

图1

图2

Answer 1

尝试打开工作簿之前，可以使用下面的函数来检查文件是否存在。 如果没有，则创build一个工作簿，否则打开现有的工作簿

 Public Function DoesFileExist(ByVal sFile) Dim oFSO As New FileSystemObject If oFSO.FileExists(sFile) Then DoesFileExist = True Else DoesFileExist = False End If End Function 

您将需要添加“Microsoft Scription运行时”参考上述function的工作