Question

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

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

我想在ActiveSheet之后添加2个工作表，分别名称为“This is Metric1”和“This is Metric2”（理想情况下，我想用“testing1”填充每个新工作表的单元格A1 “和”测试2“分别在我们可以运行之前行走。我对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需要一个带有要引用的工作表名称的字符串
- 和
```
BaseSheet.Activate
```
  因为BaseSheet已经是工作表对象引用本身

然后是一些小缺陷

与
```
Set ws = Sheets.Add(After:=Sheets(Worksheets.Count))
```
您最有可能想在工作簿的末尾添加新工作表

然后你必须使用
```
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编码模式

这被认为是不好的做法，你应该使用完全限定的范围引用来完全控制你的代码正在做什么（当代码变得更长和/或你让它丢失实际的“活动”表时很容易用户进行一些表格切换 - 与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循环添加命名工作表

2 个答案:

解决：