Объединение трех фрагментов кода "Открыть диалоговое окно" "Вырезать и вставить" и "Переименовать разделенный столбец"

ProgramBox

Объединение трех фрагментов кода «Открыть диалоговое окно» «Вырезать и вставить» и «Переименовать разделенный столбец»

Post author:admin
Запись опубликована:10 февраля, 2023
Post category:Вопросы по программированию

#vba #excel #copy-paste

#vba #excel #копировать-вставить

Вопрос:

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

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

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

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

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

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

Как только я нажимаю на сообщение «Страна не найдена» 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" amp; .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

Ответ №1:

Проблема в том, что вы ищете «Код страны» не в открытой книге, а в книге, из которой вы запускаете свой код. Итак, по сути, у вас есть рабочая книга, в которой вы запускаете свой код макроса и открываете другую рабочую книгу, с которой хотите работать (используя свой диалог). Но в 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" amp; .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) ), чтобы не полагаться на имена в открытой книге.

Ответ №2:

Включите столбец с кодами стран (в данном случае столбец W) в вашу строку при установке переменной CELL.

1. Просто напоминаю, X стоит после W в алфавите, так что он уже включен! 😉

2. Извините… мой плохой … пожалуйста, измените объект рабочей книги при настройке объекта рабочего листа.

3. в наборе ws = ThisWorkbook. Листы («Лист1») ……….. вместо этой рабочей книги укажите название открытой рабочей книги.

Ответ №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