使用 For 循环添加命名工作表

Question

我正在尝试编写一个代码，它将获取 titles/names 的列表，并为每个列表创建一个选项卡，每个工作表都有一个列表中的名称。例如，给定 ActiveSheet 上的 table（可能不一定是 sheet1）

Metric | Comments | Title
   1   | testing1 | This is Metric1
   2   | testing2 | This is Metric2

我想在 ActiveSheet 之后添加 2 个工作表，分别命名为 "This is Metric1" 和 "This is Metric2"（理想情况下，我想用"testing1" 和 "testing2"，也一样——不过我们得先走路才能运行）。我对 VBA 还是比较陌生，所以请揭露我的错误代码——这是我迄今为止尝试过的方法：

Sub test_tableTOtabs()
Dim fr As Integer
Dim lr As Integer
Dim col As String

fr = Application.InputBox("Starting row of data: ", , 2)
lr = Application.InputBox("Last row of data: ")
col = Application.InputBox("Column for Tab titles: ")

Dim BaseSheet As Worksheet
Set BaseSheet = ActiveSheet

Dim i As Integer
Dim TitleCell As String
Dim title As String
Dim ws As Worksheet

    For i = fr To lr
        Set TitleCell = col & CStr(i)
        title = ActiveSheet.Range("TitleCell").Value
        Set ws = Sheets.Add(After:=Sheets(Worksheets.Count))
            ws.Name = title
        Worksheets(BaseSheet).Activate
    Next

End Sub

我知道我可能把它复杂化了，但我不确定如何完成它 - 请帮忙！

Answer 1

您的代码有两个主要（并且相反！）缺陷

使用 string 变量名而不是变量本身
```
title = ActiveSheet.Range("TitleCell").Value
```
应该是
```
title = ActiveSheet.Range(TitleCell).Value
```
因为 "TitleCell" 只是一个字符串，而 TitleCell 是对以 "TitleCell"
使用变量而不是 string 变量本身的名称
```
Worksheets(BaseSheet).Activate
```
应该是
- 或者
```
Worksheets(BaseSheet.Name).Activate
```
  因为Worksheets需要一个带有作品名称的字符串sheet来引用
- 或
```
BaseSheet.Activate
```
  因为 BaseSheet 已经是作品sheet 对象引用本身

还有一些小瑕疵

和
```
Set ws = Sheets.Add(After:=Sheets(Worksheets.Count))
```
您很可能想在工作簿的末尾添加新的 sheets

那么你必须使用
```
Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
```
因为 Worksheets.Count 计算 Worksheets 集合中的项目，其中不包括任何 Chart 个对象

而 Sheets.Count 计算 Sheets 集合中的项目，其中包括 Worksheet 和 Chart 个对象

弱利用Application.InputBox()

和

fr = Application.InputBox("Starting row of data: ", , 2)
lr = Application.InputBox("Last row of data: ")
col = Application.InputBox("Column for Tab titles: ")

您没有使用 Application.InputBox() 函数的一个非常方便的功能，即可以指定 Type 用户必须输入的值

所以你最好使用

fr = Application.InputBox("Starting row of data: ", Default:=2, Type:=1)' force a "numeric" user input 
lr = Application.InputBox("Last row of data: ", , Default:=2, Type:=1)' force a "numeric" user input 
col = Application.InputBox("Column for Tab titles: ", Default:="C", Type:=2)' force a "string" user input

其中后者对您随后将使用的代码相当重要

 TitleCell = col & CStr(i)
 title = ActiveSheet.Range(TitleCell).value

即假设 col 是字符串列索引而不是数字索引

使用Activate/Active/Select/Selection编码模式

这被认为是不好的做法，您应该使用完全限定的范围引用来完全控制您的代码正在做什么（当代码获取时很容易丢失实际的 "active" sheet稍微长一点 and/or 让用户做一些 sheet 切换 - 就像 Application.InputBox()) 并提高代码效率（无屏幕闪烁）

因此您可以考虑对代码进行以下重构（评论中的解释）

Sub test_tableTOtabs()
    Dim fr As Long, lr As Long
    Dim col As String
    Dim cell As Range

    fr = Application.InputBox("Starting row of data: ", Default:=2, Type:=1) 'force "numeric" user input
    With Worksheets("myBaseSheetName") ' reference your "base" sheet (change "myBaseSheetName" with the name of your actual "base" sheet)

        lr = Application.InputBox("Last row of data: ", , Default:=.Cells(.Rows.Count, 1).End(xlUp).Row, Type:=1) 'force "numeric" user input and give him referenced sheet column A last not empty row indeex as default
        col = Application.InputBox("Column for Tab titles: ", Default:=Split(Cells(1, Columns.Count).End(xlToLeft).Address, "$")(1), Type:=2) 'force "string" user input and give him referenced sheet row 1 last not empty column name as default

        For Each cell In Intersect(.Range(col & ":" & col), .Rows(fr & ":" & lr)) ' loop through referenced sheet column 'col' rows from 'fr' to 'lr'
            With Sheets.Add(After:=Sheets(Sheets.Count)) ' add and reference a new sheet at the end of the workbook
                .Name = cell.value ' rename referenced sheet after current cell value
                .Range("A1").value = cell.Offset(, -1) ' fill referenced sheet cell A1 with the content of the cell one column right of the current one
            End With
        Next
    End With
End Sub

Answer 2

已解决：

Sub tableTOtabs3()
Application.ScreenUpdating = False
Dim fr As Integer
Dim lr As Integer
Dim col As String
Dim val1 As String
Dim val2 As String

fr = Application.InputBox("Starting row of data: ", Default:=2, Type:=1)
lr = Application.InputBox("Last row of data: ", , Default:=2, Type:=1)
col = Application.InputBox("Column for Tab titles: ", Default:="A", Type:=2)
val1 = Application.InputBox("Column for Value start: ", Default:="B", Type:=2)
val2 = Application.InputBox("Column for Value end: ", Default:="C", Type:=2)

Dim BaseSheet As Worksheet
Set BaseSheet = ActiveSheet

Dim i As Integer
Dim TitleCell As String
Dim title As String
Dim ws As Worksheet
Dim x As Integer

    For i = fr To lr
        On Error Resume Next

        TitleCell = CStr(col & CStr(i))
        title = Left(Replace(CStr(ActiveSheet.Range(TitleCell).Value), "/", "_"), 30)
        Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
        ws.Name = title
            If Err.Number <> 0 Then
                MsgBox "Error on Title: " & Chr(34) & title & Chr(34) & "  (Row: " & i & ")"
            End If
                For x = ToColNum(val1) To ToColNum(val2)
                        'add headers if they exist
                        If fr > 1 Then
                            BaseSheet.Cells(1, x).Copy
                            ws.Cells(1, x).PasteSpecial Paste:=xlPasteFormats
                            ws.Cells(1, x).PasteSpecial Paste:=xlPasteValues
                        End If
                    BaseSheet.Cells(i, x).Copy
                    ws.Cells(fr, x).PasteSpecial Paste:=xlPasteFormats
                    ws.Cells(fr, x).PasteSpecial Paste:=xlPasteValues
                Next
            ws.Cells(1, 1).Select
        BaseSheet.Select
    Next
BaseSheet.Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub

使用 For 循环添加命名工作表

Add named worksheets using For Loop

excel

vba

excel-2007

excel-formula

excel-tables

已解决：