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

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 " 和 "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

你的代码有两个主要的（和相反的！）缺陷

1. 使用带有变量名称的string，而不是变量本身

   title = ActiveSheet.Range("TitleCell").Value
   

   应该是

   title = ActiveSheet.Range(TitleCell).Value
   

   因为"TitleCell" 只是一个字符串，而TitleCell 是对以“TitleCell”命名的变量的引用

2. 使用变量而不是 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()）并提高代码效率（无屏幕闪烁）

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

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