VBA 如果找不到文件创建并粘贴数据

Question

希望对你有所帮助。我有一段代码，请参见 CODE 1（我的完整代码），基本上它的作用是允许用户浏览文件夹，select 一个文件。 select编辑后，它会根据 A 列中的标准（国家/地区）将工作簿分成新工作sheets，根据国家/地区重命名新工作sheets 并添加一些文本。这一切都很好。

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

因此在图 2 中您可以看到德国存在于文件夹 H:\TOV Storage Folder 中复制粘贴代码见 CODE 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 中找不到比利时并且宏停止

代码 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

基本上我需要做的是将工作簿拆分到它的国家 sheets 然后如果宏找到一个国家 sheets 就开始在 sheets 中移动=] 在 H:\TOV Storage Folder 中有相应的工作簿然后执行复制和粘贴，如果它在拆分工作簿中找到 sheet 在 H:\TOV Storage Folder 中没有相应的国家然后创建一个并执行粘贴并移动到拆分工作簿中的下一个国家 sheet 并重复过程。

以一种非常简单的方式，我需要宏来搜索拆分 sheets 并转到“啊我找到了法国 FR_ITOV_MTNG_ATNDEE.xlsx 并且你在 H:\TOV Storage Folder 中有一个工作簿复制，粘贴，下一个 sheet，啊我找到了拉脱维亚 LV_ITOV_MTNG_ATNDEE.xlsx 您没有工作簿 H:\TOV Storage Folder 为拉脱维亚创建工作簿，复制、粘贴！等等。

如果我的问题很长，我深表歉意，我只是想让我的问题透明化。

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

一如既往，我们非常感谢您的帮助。

代码 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

您可以使用下面的函数来检查文件是否存在，然后再尝试打开工作簿。如果没有则创建工作簿，否则打开现有工作簿

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 Runtime'[=17=] 引用才能使上述功能正常工作

VBA 如果找不到文件创建并粘贴数据

VBA if file not found create and paste data

excel

vba

copy-paste