0

我正在尝试编写一个代码，该代码将获取标题/名称列表，并为每个标题/名称创建一个选项卡，每个工作表都有一个列表中的名称。例如，给定 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

我知道我可能过于复杂了，但我不知道如何完成这个 - 请帮助！

4

2 回答 2

7

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

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

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

    应该

    title = ActiveSheet.Range(TitleCell).Value

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

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

    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对象

    whileSheets.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
于 2018-03-13T07:27:22.090 回答
0

解决了：

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
于 2018-03-13T16:55:06.017 回答