Question

我很难弄清楚如何使用活动单元格值来命名工作表。

我使用的是Ron de Bruin写的代码，用于过滤数据并将其拆分为不同的工作表。参见下面的链接以获取有关代码的参考

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

我尝试使用VBA编辑器中的step into函数来确定工作表名称的来源，并且ive注意到代码使用了新创建的工作表的第一行。（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）中，我得到以下信息：

然后，根据新创建的临时工作表（ws2）中列A中的条件，循环并过滤掉我原始工作表中的数据，并使用过滤后的数据创建新工作表。

  '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”

但是我希望将其命名为：

“ B 1 A 2”

“ B 2 A 3”

“ B 3 A 4”

我看到问题出在创建的临时工作表（ws2）中，在该工作表中它仅返回A列值，因为B不存在。

如果我将原始工作表中A列的内容复制到临时工作表（ws2）中，将会干扰过滤器吗？

如果这没有意义，请询问更多信息。

Answer 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

有关VBA脚本字典的在线资料很多，例如https://excelmacromastery.com/vba-dictionary/（我不能担保这个网站，它在Google中名列前茅）。

使用临时工作表中的活动单元格值拆分worksheet.name

1 个答案: