连接两个宏

Question

我希望你一切都好，可以提供帮助。我有两段代码试图加入一个宏。

我的第一段代码允许用户单击一个命令按钮，该按钮打开一个 txt 框并允许用户选择一个文件。 选择该文件后，我希望第二段代码执行其操作，即通过 F 列并找到一个国家/地区，然后创建一个新工作表，将该国家/地区的数据复制并粘贴到新工作表中并命名该工作表对于该国家/地区，然后返回 F 列并为其他国家/地区重复。

我添加了一张图片，因为我认为它可能会更容易。看到最后

这两段代码都可以独立工作，我只需要加入它们即可。

第一段代码**选择文件和msb框**

Sub Click_Me()

    Application.ScreenUpdating = False 'Turns off switching to exported excel file once it gets opened
    Application.DisplayAlerts = False 'Turns off automatic alert messages
    Application.EnableEvents = False '
    Application.AskToUpdateLinks = False 'Turns off the "update links" prompt

    'User prompt, choose HCP file
    MsgBox "Choose TOV file missing consent information"

        'Alternative way to open the file
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    fd.AllowMultiSelect = False

     'Assign a number for the selected file
    Dim FileChosen As Integer
    FileChosen = fd.Show
    If FileChosen <> -1 Then
    'Didn't choose anything (clicked on CANCEL)
        MsgBox "No file selected - aborted"
        End 'Ends file fetch and whole sub
    End If


End Sub

第二段代码**将F列分隔到其他表格中复制粘贴并命名**

Option Explicit

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:Q" & .Cells(.Rows.Count, 1).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

If FileChosen <> -1 Then
    MsgBox "No file selected - aborted"
Else
    Call Filter
End If