Присоединение к трем частям кода «Открыть диалоговое окно» «Вырезать и вставить» и «Разделить колонну переименования»

Question

Надеюсь, вы сможете помочь. У меня ниже трех частей кода. Все три работают отлично независимо друг от друга. Все компилирует макрос, просто не выполняется правильно.

Первый фрагмент кода Sub Open_Workbook_Dialog() открывает диалоговое окно и позволяет пользователю выбрать файл.

Вторая часть кода Public Sub Sample() заголовков столбцов поиск для текста «COUNTRYCODE», затем вырезает этот столбец и вставляет его в колонку F.

Третья часть кода Public Sub Filter() занимает столбец F и разбивает ее на новые рабочие листы и переименовывает рабочий лист на основе страны.

Так что, по сути, макрос должен сделать это, открыть диалоговое окно, получить файл, найти столбец страны, где бы он ни находился, вырезать его и вставить в столбец F, а затем разбить этот столбец на новые листы и переименовать.

Как я уже сказал, весь код работает нормально независимо, но когда я их складываю. Диалоговое окно Я выбираю мой файл, то я получаю Msgbox «Страна не найден» даже если CountryCode Колонка хорошо в диапазоне Я думаюSet aCell = .Range("A1:X50") CountryCode в колонке W.

После того, как я нажимаю MsgBox «Страна не найдена»Public Sub Filter() выполняет и разделяет и переименовывает неправильный столбец. Находка, похоже, не происходит, поэтому вырезать и вставить не происходит.

У меня есть фото для лучшего понимания.

Страна Не найдено

Разделить неправильным F

КОД НИЖЕ

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

Проблема в том, что вы не ищете "COUNTRYCODE" в открытую книгу, но в рабочей книге вы используете свой код. Таким образом, в основном у вас есть книга, в которой вы начинаете свой макрокод и открываете другую рабочую книгу, с которой хотите работать (используя ваш диалог). Но в вашем Public Sub Sample() вашей проблемы линия:

Set ws = ThisWorkbook.Sheets("Sheet1") 

Проблема заключается в том, что вы ссылаетесь на книгу, где ваш код макроса записывается и выполняется в помощью ThisWorkbook. Поскольку вы не знаете имя файла в своем Public Sub Sample(). Я редактировал свой код, чтобы работать так, как надо:

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 

Вы также можете изменить строки с .Sheets("Sheet1") (или .Worksheets("Sheet1")) в .Sheets(1) (или .Worksheets(1)), так что вы не полагаться на именование в открытая рабочая тетрадь.

Answer 2

Включите столбец, в котором в вашей строке есть CountryCodes (столбец W в этом случае), при установке переменной aCell.

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