Разделить имя листа с использованием значений активных ячеек из временного листа

Мне трудно понять, как назвать рабочий лист, используя значение активной ячейки.

Я использую код, написанный Роном де Брюном, для фильтрации данных и разделения их на разные рабочие листы. См. Ссылку ниже для справки по коду

https://www.rondebruin.nl/win/s3/win006_4.htm

Я попытался использовать шаг в функцию в редакторе VBA, чтобы определить, откуда взялось имя рабочего листа, и я заметил, что код использует первую строку вновь созданного рабочего листа. (WS2)

Sub Copy_To_Worksheets()
Dim CalcMode As Long
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim FieldNum As Long
Dim My_Table As ListObject
Dim ErrNum As Long
Dim ActiveCellInTable As Boolean
Dim CCount As Long
Dim wSheetStart As Worksheet

'Select a cell in the column that you want to filter in the List or Table
'Or use this line if you want to select the cell that you want with code.
'In this example I select a cell in the Gender column
'Remove this line if you want to use the activecell column
Application.GoTo Sheets("SplitInWorksheets").Range("K7")

If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
    MsgBox "This macro is not working when the workbook or worksheet is protected", _
           vbOKOnly, "Copy to new worksheet"
    Exit Sub
End If

Set rng = ActiveCell

'Test if rng is in a a list or Table
On Error Resume Next
ActiveCellInTable = (rng.ListObject.Name <> "")
On Error GoTo 0

'If the cell is in a List or Table run the code
If ActiveCellInTable = True Then

    Set My_Table = rng.ListObject
    FieldNum = rng.Column - My_Table.Range.Cells(1).Column + 1

    'Show all data in the Table/List
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    ' Add a worksheet to copy the a unique list and add the CriteriaRange
    Set ws2 = Worksheets.Add

    With ws2
        'first we copy the Unique data from the filter field to ws2
        My_Table.ListColumns(FieldNum).Range.AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("A1"), Unique:=True

Приведенный выше код просматривает ячейку k7 и возвращает все уникальные значения в этом столбце.

Пример:

В исходном листе у меня есть что-то вроде этого:

A  B  C  D  E  F  G  H  I  J  K  L  M
1                             2
1                             2
2                             3
3                             4

В созданном временном листе (ws2) я получаю следующее:

 A 
 2
 3
 4 

Затем он выполняет цикл и фильтрацию данных из моего исходного рабочего листа на основе критериев в столбце A из вновь созданного временного рабочего листа (ws2) и создает новые рабочие листы с отфильтрованными данными.

  'loop through the unique list in ws2 and filter/copy to a new sheet
        Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
        For Each cell In .Range("A2:A" & Lrow)

            'Filter the range
            My_Table.Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
                                                                  Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")

            CCount = 0
            On Error Resume Next
            CCount = My_Table.ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
            On Error GoTo 0

            If CCount = 0 Then
                MsgBox "There are more than 8192 areas for the value : " & cell.Value _
                     & vbNewLine & "It is not possible to copy the visible data to a new worksheet." _
                     & vbNewLine & "Tip: Sort your data before you use this macro.", _
                       vbOKOnly, "Split in worksheets"
            Else
                Set WSNew = Worksheets.Add(after:=Sheets(Sheets.Count))
                On Error Resume Next
                WSNew.Name = "Sample " & cell.Offset(0, 10).Value & " NIIN " & cell.Value

Теперь, когда он достигает этой части кода

  Set WSNew = Worksheets.Add(after:=Sheets(Sheets.Count))
                On Error Resume Next
                WSNew.Name = "B " & cell.Offset(0, 10).Value & " A " & cell.Value

Рабочие листы называются:

«B (ПУСТОЙ) A 2»

"B (ПУСТОЙ) A 3"

"B (ПУСТОЙ) A 4"

Однако я бы хотел, чтобы он назывался:

«В 1 А 2»

«В 2 А 3»

«В 3 А 4»

Я вижу, что проблема заключается в созданном временном листе (ws2), где он возвращает только значения столбца A, потому что B не существует.

Будет ли это мешать фильтру, если содержимое столбца A из моего исходного рабочего листа скопировано на временный рабочий лист (ws2)?

Если это не имеет смысла, запросите дополнительную информацию.

TL; DR. Учитывая вопрос, я не понимаю, насколько актуален весь этот код.

urdearboy 10.08.2018 17:05

Действительно ли к названию добавляется слово Blank? Или это просто B A 2?

urdearboy 10.08.2018 17:07

@urdearboy я не был уверен, будет ли код полезен или нет. Вы предлагаете мне его удалить? слово Blank не добавляется, это B A 2. Я должен был прояснить эту часть. Извинения

CCP 10.08.2018 17:07

Код кажется слишком сложным для того, что вы пытаетесь достичь ... по крайней мере, то, что я думаю, вы пытаетесь достичь ... Я сомневаюсь в себе, потому что I think вы хотите просто добавить листы с увеличивающимся именем ... не так ли?

Zac 10.08.2018 17:08

@urdearboy: добрый крик!

Zac 10.08.2018 17:09

@Zac, насколько я понимаю, рабочие листы названы на основе того, что находится на временном листе (ws2). Значения из временного рабочего листа копируются из определенного столбца на исходном листе с данными. Затем временный рабочий лист фильтрует данные по одной строке с помощью расширенного фильтра, создает новый рабочий лист и присваивает ему имя значения ячейки, с помощью которого он фильтрует его.

CCP 10.08.2018 17:18

Я пытался сделать так, чтобы рабочие листы назывались на основе значений двух ячеек на исходном листе. Есть ли способ скопировать значение ячейки столбца k и столбца a на временный рабочий лист (ws2), а затем отфильтровать только по столбцу A из временного рабочего листа (ws2), и когда код создает имя для рабочих листов, чтобы также иметь возможность найти значение ячейки в B для целей именования.

CCP 10.08.2018 17:22

Можете ли вы предоставить образцы своих рабочих листов?

Zac 10.08.2018 17:30

Итак, на вашем первом рисунке есть две строки с 1 в столбце A и 2 в столбце K. Если повторяющиеся значения в A всегда соответствуют повторяющимся значениям в K, возможно, используйте словарь для создания ваших уникальных значений, а не расширенный фильтр, и тогда вы могли бы сохраните значение K рядом со значением A. Имеет ли это смысл?

SJR 10.08.2018 17:31

@zac определенно. Как лучше всего это сделать?

CCP 10.08.2018 17:43

@SJR это имеет смысл. Есть ли сайт, на котором я могу сослаться на то, как это сделать?

CCP 10.08.2018 17:45
0
11
326
1
Перейти к ответу Данный вопрос помечен как решенный

Ответы 1

Ответ принят как подходящий

Вот пример, с которого вы можете начать.

Sub x()

Dim oDic As Object, v, r As Range

Set oDic = CreateObject("Scripting.Dictionary")

With oDic
    For Each r In Range("A2", Range("A" & Rows.Count).End(xlUp))
        oDic.Item(r.Value) = r.Offset(, 10).Value
    Next r
    For Each v In .keys
        MsgBox "B " & .Item(v) & " A " & v
    Next v
End With

End Sub

enter image description here

В Интернете есть много материалов по словарям сценариев VBA, например https://excelmacromastery.com/vba-dictionary/ (я не могу поручиться за этот сайт, он просто занял первое место в Google).

позволит ли словарь затем фильтровать по столбцу K и извлекать соответствующие ему данные? Я считаю, что для этой цели используется расширенный код фильтра, предоставленный Роном. Я попробую и доложу. Спасибо.

CCP 10.08.2018 19:10

Я пропустил ваш комментарий, но считаю, что этот ответ вам помог. Отвечает ли он на ваш вопрос выше?

SJR 13.08.2018 16:04

Прочитав больше о словарях, я считаю, что это мне поможет. В настоящее время я ищу способ его использовать. Спасибо, SJR.

CCP 13.08.2018 16:27

Хорошо, с удовольствием. Задайте еще один вопрос, если у вас есть конкретная проблема.

SJR 13.08.2018 16:39

Другие вопросы по теме