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

Question

VBA根据列中的一系列值命名新工作表嗨，我对编写VBA有些新意。我花了整个周末在几件作品上工作，并让他们中的大部分工作。我对这部分和其他一些部分感到难过。

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

例如，On Distribution（3）工作表，在B列中，我有13个不同的值。

我想将新创建的工作表命名为Distribution（3）工作表上单元格B2中的文本值。

然后我想创建另一个工作表，并根据Distribution（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

VBA根据列中的一系列值命名新工作表

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

2

3

2 个答案: