新しいブックにコピーして保存するVBA

Question

あなたが助けてくれることを願っています。私は以下のコードを持っています。基本的には、ユーザーがExcelシートを選択できるダイアログボックスを開き、それを国のコラム（11）にフィルタリングしてフィルタリングし、その国をコピーして新しいワークシートに貼り付けます。その国は次の国の行動を繰り返します。

私が今したいことは、新しいシートを作成して名前を付ける代わりに、それをやりたいことです。各国の新しいワークブックを作成し、その情報をコピーして貼り付けてから、新しいブックを保存してフォルダに命名したいと考えています。

マイコードは以下のとおりです。

いつも大歓迎です。

Sub Open_Workbook_Dialog() 

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 '<--|Calls the Filter Code and executes 

End If 


End Sub 

Public Sub Filter() 
    Dim rCountry As Range, helpCol As Range 

    With Worksheets("CountryList") '<--| 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:Y" & .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(11).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 11, 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 '<--... 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) 
End Sub 

Answer 1

wokbook変数を追加し、これが完全なものではありませんが、私はあなたがこれらの線に沿って何かをしたいと思う：

'Add this above the loop  
Dim wb As Workbook 

'Replace where you create a new sheet with something similar to this 
Set wb = Application.Workbooks.Add 
wb.SaveAs Filename:=rCountry.Value2 
.SpecialCells(xlCellTypeVisible).Copy wb.Sheets(1).Range("A1") 

希望