두 매크로 가입

Question

나는 당신이 잘하고 도움이되기를 바랍니다. 하나의 매크로에 합류하려고하는 코드 두 조각이 있습니다.

내가 가진 첫 번째 코드는 사용자가 txt 상자를 열고 사용자가 파일을 선택할 수있는 명령 단추를 클릭 할 수있게합니다. 해당 파일을 선택하면 두 번째 코드 조각이 F 열을 통과하여 국가를 찾은 다음 새 시트 복사본을 만들고 해당 국가의 데이터를 새 시트와 이름으로 붙여 넣기를 원합니다. 그 다음에 F 장으로 돌아가서 다른 나라들에 대해서도 반복하십시오.

내가 쉽게 생각할 수 있으므로 사진을 추가했습니다. 끝 부분을 참조

두 조각의 코드는 모두 독립적으로 작동하기 때문에 합치면됩니다.

코드의

1ST 조각 ** 파일을 선택하고 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 

코드의

2ND 조각 ** 별도의 열 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