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