Question

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

我的第一段代码允许用户点击打开txt框的命令按钮，并允许用户选择文件。一旦选择了该文件，我就希望第二段代码完成它的事情，它通过列F并找到一个国家，然后创建一个新的工作表副本并将该国家/地区的数据粘贴到新工作表中并命名该工作表然后返回F列并重复其他国家/地区。

我添加了一张照片，因为我觉得它可能会让它更容易。看到结束

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

第1段代码**选择文件和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

第2段代码**将列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

加入两个宏

1 个答案: