ファイルが見つからない場合はVBAデータを作成して貼り付けてください

Question

お手伝いができたら幸いです。コードの一部にCODE 1（コード全体が表示されています）があり、基本的にはユーザーがフォルダを移動してファイルを選択できるようになっています。選択されると、列Aの基準（国）に基づいてワークブックが新しいワークシートに分割され、新しいワークシートの名前が変更され、テキストが追加されます。すべてこれはうまく動作します。

私が直面している問題は、ブックが別のシートに分割されている場合です。図1を参照して、特定の国のシートをコピーして別のフォルダに保存されているブックに貼り付ける必要があります。図2を参照してください。ワークブックがフォルダ内に既に存在する場合（私の例ではドイツ）、ワークブックが存在しない場合（ベルギー）、その国の新しいワークブックを作成し、データを新しいブックに追加します。

だからピック2に、あなたはドイツが H:\TOV Storage Folder 、コピー＆ペーストのコードは罰金CODE 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でベルギーを見つけることができないというエラーがスローバックとマクロが

CODE 3

を停止3210

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 

既存のブックを開いたあなたは、私が行っている