VBA根据列中的值范围命名新工作表

Question

VBA 根据列中的值范围命名新工作表 你好， 我对编写 VBA 有点陌生。我整个周末都在研究几件作品，并且大部分作品都在工作。我对这部分和其他一些部分感到困惑。

我正在尝试创建一个新工作表并根据不同工作表上的列中的值对其进行命名。

例如，在分布 (3) 工作表中，在 B 列中，我有 13 个不同的值。

我想将新创建的工作表命名为分布 (3) 工作表上单元格 B2 中的文本值。

然后我想创建另一个工作表并根据分布 (3) 工作表上 B3 中的值对其命名。

或添加 x 个工作表，然后为它们命名。

我已经找到了 VBA 来创建 x 个工作表，但我必须手动输入所需的工作表数量（在循环中）。

可行的是获取 B2:B14 范围内的值的计数，然后如果我能弄清楚如何将该值传递到现有代码中，则添加该工作表计数。

我尝试将名称保存到变量中。 （据我所知，可能是一个数组，但不知道如何提取每个数组中的值）。我只知道如何将这些值打印到立即窗口。请参阅下面的#1。

1 我在 StackOverflow 上找到了这个 VBA。谢谢。

    Sub RegionNames()
    Dim DatArr As Range
    Dim AuxDat As Range
    Dim CellCnt As Integer

    Set DatArr = _
    Application.InputBox( _
    "Select a contiguous range of cells.", _
    "SelectARAnge Demo", _
    Selection.Address, , , , , 8)

    CellCnt = DatArr.Count

    If DatArr.Columns(1).Column > 1 Then  '<<small error trap in case the user     selects column A
    Set AuxDat = DatArr.Offset.Offset(0, -1)
    End If

    Debug.Print AuxDat.Count
    Debug.Print AuxDat(1).Value
    Debug.Print DatArr(0) ' This is "Region"
    Debug.Print DatArr(1) ' This is "Atlanta"
    Debug.Print DatArr(2) ' ...
    Debug.Print DatArr(3)
    Debug.Print DatArr(4)
    Debug.Print DatArr(5)
    Debug.Print DatArr(6)
    Debug.Print DatArr(7)
    Debug.Print DatArr(8)
    Debug.Print DatArr(9)
    Debug.Print DatArr(10)
    Debug.Print DatArr(11)
    Debug.Print DatArr(12)
    Debug.Print DatArr(13)
    Debug.Print DatArr(14)

    End Sub

2

    Sub RegionList()
        Range("B2").Select
        Range(Selection, Selection.End(xlDown)).Select
    End Sub

3

    Sub MakeNewTab()
    Dim ws As Worksheet
    'ws.Name = "NewSheet"

    Set ws = Sheets.Add(After:=Sheets(Sheets.Count))

    Application.WindowState = xlNormal
    Sheets("Distribution (3)").Select
    Sheets("Distribution (3)").Name = "Distribution (3)"
    Range("B2:B14").Select
    Sheets("Sheet4").Select
    Sheets("Distribution (3)").Select
    End Sub

Answer 1

您需要做的只是创建一个循环来遍历您需要从中创建名称的范围，在您的情况下通过Distribution (3) 表和Range("B2:B14")。 即代码看起来像这样。

 Sub MakeNewTab()
    Dim ws As Worksheet

    For i = 2 To 14
       Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
       ws.Name = Sheets("Distribution (3)").Range("B" & i).Value
    Next i
End Sub

那你就随便叫吧。

Answer 2

实际上，我只是制作了一个执行此操作的 Excel。我写了以下内容：

    Dim c as Range
    Dim d as Range
    Dim PEndRange As Long
    Dim Pitem As String
    Dim PStartRange As Long
    Dim rng As Range
    Dim worksh As Long

    Set d = Nothing
    Set c = Nothing

'first I sort the table

    With Worksheets("Sheet1").Range("A1").EntireRow
    Set c = .Find("HEADER", LookIn:=xlValues)
    Set c = Worksheets("Sheet1").Cells(2, c.Column)
    Set d = .Find("VALUE", LookIn:=xlValues)
Pitem = c.Value
End With

'This grabs the Value of the cell in row 2 of whatever column contains the header you're searching through. You can do a loop and lookup instead using counta of cells(x,c.Column) for x = 2 to lastrow, then define the last row using 
ActiveWorkbook.Worksheets("Sheet1").Cells(ActiveWorkbook.Worksheets("Import").Rows.count, "A").End(xlUp).Row
, and then from there do a counta on Range(c.address).EntireColumn of that string, then set that value +1 as your range limit, then repeat after setting x as that value.


    If (c.EntireColumn.Find(what:=Pitem, lookat:=xlWhole, After:=Cells(2, c.Column)).Row)  0 Then
    PStartRange = c.EntireColumn.Find(what:=Pitem, After:=Cells(1, c.Column)).Row
    PEndRange = c.EntireColumn.Find(what:=Pitem, After:=Cells(1, c.Column), searchdirection:=xlPrevious).Row

    worksh = Application.Sheets.count
    worksheetexists = False
    For X = 1 To worksh
        If Worksheets(X).Name = left(Pitem, 29) Then 'trimmed in case string is longer than max allowed for sheet name
            worksheetexists = True
            GoTo NextStep:
            Exit For
        End If
    Next X

    Worksheets("Template").Copy After:=Sheets(Sheets.count) 'only if you have a template that already exists, otherwise you can just create a new sheet here
    Set newsheet = ActiveSheet
    newsheet.Name = left(Pitem, 29)

    NextStep:

    ActiveWorkbook.Worksheets(left(Pitem, 29)).Activate

End Sub