「開く」ダイアログボックス「切り取りと貼り付け」と「列の名前を変更する」の3つのコードを結合する

Question

私はあなたが助けてくれることを願っています。私は以下の3つのコードを持っています。 3つすべてが互いに完全に独立して動作します。マクロをコンパイルすると、正しく実行されません。

最初のコードSub Open_Workbook_Dialog()は、ダイアログボックスを開き、ユーザーがファイルを選択できるようにします。

テキスト「国番号」のコードPublic Sub Sample()検索列見出しの第二の部分は、それの列に、その列及びペーストを切断F.

コードPublic Sub Filter()の3枚が列Fをとり、新しいワークシートにそれを分割し国に基づいてワークシートの名前を変更します。

本質的には、ダイアログボックスを開いてファイルを取得し、国の列を見つけてカットし、列Fに貼り付けてからこの列を新しいシートに分割して名前を変更します。

私はすべてのコードが独立して動作すると言いましたが、私はそれらをまとめました。ダイアログボックスは、私がMSGBOX のCountryCode列を範囲でもあるにもかかわらずは私が考える「国が見つかりません」Set aCell = .Range("A1:X50")国番号が列にW.

で取得、その後、私のファイルを選択し開きます私はMsgBoxにをクリックすると「国が見つかりません」Public Sub Filter()は、間違った列を実行し、分割して名前を変更します。見つけることは起こっていないように見えるので、カットアンドペーストは起こっていません。

わかりやすくするために写真を添付し​​ました。

国ではないが、問題はあなたが "国番号" を検索していないということですBELOW間違っF

CODE

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

Call Filter '<--|Calls the Filter Code and executes 

End If 


End Sub 
Public Sub Sample() 
    Dim ws As Worksheet 
    Dim aCell As Range, Rng As Range 
    Dim col As Long, lRow As Long 
    Dim colName As String 

    '~~> Change this to the relevant sheet 
    Set ws = ThisWorkbook.Sheets("Sheet1") 

    With ws 
     Set aCell = .Range("A1:X50").Find(What:="CountryCode", LookIn:=xlValues, LookAt:=xlWhole, _ 
        MatchCase:=False, SearchFormat:=False) 
    '~~> If Found 
    If Not aCell Is Nothing Then 

    '~~> Cut the entire column 
    aCell.EntireColumn.Cut 

    '~~> Insert the column here 
    Columns("F:F").Insert Shift:=xlToRight 

    Else 
    MsgBox "Country Not Found" 

    End If 
    End With 
End Sub 
Public Sub Filter() 
    Dim rCountry As Range, helpCol As Range 

    With Worksheets("Sheet1") '<--| 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(6).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 6, 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

によって

スプリットを見つけました開いているワークブックを開きますが、コードを実行しているワークブックにあります。基本的には、マクロコードを開始し、作業する別のワークブックを（ダイアログを使用して）開くブックがあります。

Set ws = ThisWorkbook.Sheets("Sheet1") 

問題は、あなたのマクロのコードが書かれており、ThisWorkbookを使用して実行されたワークブックを、参照しているということです。しかし、あなたのPublic Sub Sample()問題でラインです。 Public Sub Sample()のファイル名が分からないためです。 .Sheets(1)（または.Worksheets(1)）にあなたはまた、.Sheets("Sheet1")（または.Worksheets("Sheet1")）で行を変更する場合があります

Sub Open_Workbook_Dialog() 

Dim my_FileName As Variant 
Dim my_Workbook As Workbook 

    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 
    Set my_Workbook = Workbooks.Open(Filename:=my_FileName) 

    Call Sample(my_Workbook)'<--|Calls the Filter Code and executes 

    Call Filter(my_Workbook) '<--|Calls the Filter Code and executes 

    End If 
End Sub 

Public Sub Sample(my_Workbook as Workbook) 
    Dim ws As Worksheet 
    Dim aCell As Range, Rng As Range 
    Dim col As Long, lRow As Long 
    Dim colName As String 

    '~~> Change this to the relevant sheet 
    Set ws = my_Workbook.Sheets("Sheet1") 

    With ws 
    Set aCell = .Range("A1:X50").Find(What:="CountryCode", LookIn:=xlValues, LookAt:=xlWhole, _ 
       MatchCase:=False, SearchFormat:=False) 
    '~~> If Found 
    If Not aCell Is Nothing Then 
     '~~> Cut the entire column 

     aCell.EntireColumn.Cut 

     '~~> Insert the column here 

     Columns("F:F").Insert Shift:=xlToRight 
    Else 
     MsgBox "Country Not Found" 
    End If 
    End With 
End Sub 

Public Sub Filter(my_Workbook as Workbook) 
    Dim rCountry As Range, helpCol As Range 

    With my_Workbook.Worksheets("Sheet1") '<--| 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(6).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 6, 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 2

aCell変数を設定しているときに、国コード（この場合は列W）を含む列を含む行を含めます。

Answer 3

これはおそらく参考になる問題です。

これは、新しく開かれたワークブックの参照を渡さないため、あなたの他のSubsはあなたが話していることを知りません！

私はどこの変更をしておくことが表示する例を作りました：

Sub Open_Workbook_Dialog() 
Dim my_FileName As Variant 

'~~> Changes here 
Dim MainWbk As Workbook 
Dim OpenedWbk As Workbook 
'~~> Changes here 
Set MainWbk = ThisWorkbook 

MsgBox "Pick your TOV file" 
my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") 

If my_FileName <> False Then 
    '~~> Changes here 
    Set OpenedWbk = Workbooks.Open(Filename:=my_FileName) 
    '~~> Changes here 
    Call Sample(OpenedWbk, MainWbk) 
    ''~~> Same changes to do here 
    'Call Filter 
End If 


End Sub 

'~~> Changes here (arguments to pass the references of the workbooks) 
Public Sub Sample(OpenedWbk As Workbook, MainWbk As Workbook) 
    Dim ws As Worksheet 
    Dim aCell As Range, Rng As Range 
    Dim col As Long, lRow As Long 
    Dim colName As String 

    '~~> Changes here 
    Set ws = OpenedWbk.Sheets("Sheet1") 

    With ws 
     Set aCell = .Range("A1:X50").Find(What:="CountryCode", _ 
        LookIn:=xlValues, LookAt:=xlWhole, _ 
        MatchCase:=False, SearchFormat:=False) 
     If Not aCell Is Nothing Then 
      aCell.EntireColumn.Cut 
      '~~> Changes here 
      MainWbk.Columns("F:F").Insert Shift:=xlToRight 
     Else 
      MsgBox "Country Not Found" 
     End If 
    End With 
End Sub