VBA如果找不到文件創建並粘貼數據

Question

我希望你能幫上忙。我有一段代碼，請參閱代碼1（我的代碼完整），它本質上是允許用戶瀏覽文件夾，選擇一個文件。一旦選定，它將基於A列中的標準（國家）的工作簿分成新工作表，在國家之後重命名新工作表並添加一些文本。所有這些工作正常。

我面臨的問題是，當工作簿分成不同的工作表時。請參閱圖1，然後我需要將特定的國家/地區表複製並粘貼到已存儲在其他文件夾中的工作簿中。請參閱圖2.如果工作簿已存在於文件夾中（在我的德國示例中），但如果工作簿不存在（比利時），則我工作正常的代碼工作良好，我需要代碼爲該國家創建新的工作簿，然後粘貼數據導入新的工作簿。

所以在產品圖2可以看出，德國存在於文件夾H:\TOV Storage Folder 和複製和粘貼代碼，請參閱代碼2個工作正常

CODE 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所以CODE 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 

基本上我所需要發生的是對工作簿中分裂到其國片材然後對於宏開始通過片材移動，如果它發現具有存在於H:\TOV Storage Folder相應工作簿然後執行一個國家片複製並粘貼，如果它在拆分工作簿中找到工作簿中沒有相應國家/地區的工作表（H:\TOV Storage Folder），則創建一個工作簿並執行粘貼並移至拆分工作簿中的下一個國家/地區工作表並重復處理。

在一個非常簡單的方法，我需要的宏 搜索通過裂張，去「啊，我發現法國FR_ITOV_MTNG_ATNDEE.xlsx，你必須在H:\TOV Storage Folder複製，粘貼，下一張工作簿，啊，我發現拉脫維亞LV_ITOV_MTNG_ATNDEE的.xlsx你沒有在H:\TOV Storage Folder工作簿拉脫維亞創建工作簿，複製，粘貼！等等。

我道歉，如果我的問題是漫長的我只想讓我的問題是透明的。

可以在我的代碼修改解決我的問題？

像往常一樣，所有的幫助非常感謝。

CODE 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 

您將需要添加`微軟Scription運行」的上述功能參考工作