Question

我是VBA的新手。我找到了基于列（A1，A2，A3等）中的列表复制和重命名多个模板工作表的代码。我尝试修改它来循环一行，即单元格A1，B1，C1，D1，E1，但没有运气。我想复制多个模板，并根据通过用户输入表单输入的帐号重命名它们。我创建了一个工作表LedgerArray，它列出了每个帐号的工作表名称。例如：

row1: 1Savings, 1Shares, 1Statement
row2: 2Savings, 2Shares, 2Statement

提前致谢

Hello Ambie，您的努力非常感谢，尤其是婴儿。我开发了下面的代码。它的工作原理是复制和重命名模板，并将用户输入分配给特定的模板标题单元格。这些任务适用于新帐户。单独的用户表单适用于现有帐户。如您所示，不包括错误处理程序（例如，输入重复的帐号）。此外，应该将共享事务数据传输到重命名的工作表中的第一个空行的代码部分不起作用。执行时，代码不返回语法错误，但第一个空行的结果为空。

Sub CommandButton1_Click()
    Dim Template As String, str1 As String, str2 As String, str3 As String, str4 As String, str5 As String
    Dim ws As Worksheet, lrShar As Long, lrSav As Long, lrTD As Long, lrStmnt As Long
    str1 = "Shares"
    str2 = "Savings"
    str3 = "TimeDeposit"
    str4 = "Loans"
    str5 = "Statements"

    'hide the form
    frmAddSheet.Hide

    'Select 1st template
    Template = "TemplateShares"

    'copy template to create a new sheet
    Sheets(Template).Select
    Sheets(Template).Copy After:=Sheets(Sheets.Count)

    'make the sheet visible in case the template is hidden
    ActiveSheet.Visible = xlSheetVisible

    'Rename the sheet
    ActiveSheet.Name = AccNumTextBox & str1

    'Transfer Heading data
    Set ws = Sheets(AccNumTextBox & str1)
    ws.Range("A4") = AccNumTextBox.Value
    ws.Range("B5") = DTPicker4.Value
    ws.Range("B6") = Reference.Value
    ws.Range("B7") = RegFeeTextBox.Value
    ws.Range("B8") = NameTextBox.Value
    ws.Range("B9") = AddressTextBox.Value
    ws.Range("B10") = TelNumTextBox.Value
    ws.Range("B11") = EmailTextBox.Value
    ws.Range("B12") = ComboBox2.Value
    ws.Range("B13") = DOBDTPicker.Value

    'transfer Share transaction data
    lrShar = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
    ws.Range("A" & lrShar).Value = DTPicker4.Value
    ws.Range("B" & lrShar).Value = Reference.Value
    ws.Range("C" & lrShar).Value = SharesTextBox.Value

    'Select 2nd template
    Template = "TemplateSavings"

    'copy template to create a new sheet
    Sheets(Template).Select
    Sheets(Template).Copy After:=Sheets(Sheets.Count)

    'make the sheet visible in case the template is hidden
    ActiveSheet.Visible = xlSheetVisible

    'Rename the sheet
    ActiveSheet.Name = AccNumTextBox & str2

    'Transfer Heading data
    Set ws = Worksheets(AccNumTextBox & str2)
    ws.Range("A4") = AccNumTextBox.Value
    ws.Range("B5") = DTPicker4.Value
    ws.Range("B6") = Reference.Value
    ws.Range("B7") = RegFeeTextBox.Value
    ws.Range("B8") = NameTextBox.Value
    ws.Range("B9") = AddressTextBox.Value
    ws.Range("B10") = TelNumTextBox.Value
    ws.Range("B11") = EmailTextBox.Value
    ws.Range("B12") = ComboBox2.Value
    ws.Range("B13") = DOBDTPicker.Value

    'Select 3rd template
    Template = "TemplateTimeDeposit"

    'copy template to create a new sheet
    Sheets(Template).Select
    Sheets(Template).Copy After:=Sheets(Sheets.Count)

    'make the sheet visible in case the template is hidden
    ActiveSheet.Visible = xlSheetVisible

    'Rename the sheet
    ActiveSheet.Name = AccNumTextBox & str3

    'Transfer Heading data
    Set ws = Worksheets(AccNumTextBox & str3)
    ws.Range("A4") = AccNumTextBox.Value
    ws.Range("B5") = DTPicker4.Value
    ws.Range("B6") = Reference.Value
    ws.Range("B7") = RegFeeTextBox.Value
    ws.Range("B8") = NameTextBox.Value
    ws.Range("B9") = AddressTextBox.Value
    ws.Range("B10") = TelNumTextBox.Value
    ws.Range("B11") = EmailTextBox.Value
    ws.Range("B12") = ComboBox2.Value
    ws.Range("B13") = DOBDTPicker.Value

    'Select 4th template
    Template = "TemplateLoans"

    'copy template to create a new sheet
    Sheets(Template).Select
    Sheets(Template).Copy After:=Sheets(Sheets.Count)

    'make the sheet visible in case the template is hidden
    ActiveSheet.Visible = xlSheetVisible

    'Rename the sheet
    ActiveSheet.Name = AccNumTextBox & str4

    'Select 5th template
    Template = "TemplateStatement"

    'copy template to create a new sheet
    Sheets(Template).Select
    Sheets(Template).Copy After:=Sheets(Sheets.Count)

    'make the sheet visible in case the template is hidden
    ActiveSheet.Visible = xlSheetVisible

    'Rename the sheet
    ActiveSheet.Name = AccNumTextBox & str5

    'Transfer Heading data
    Set ws = Worksheets(AccNumTextBox & str5)
    ws.Range("B8") = AccNumTextBox.Value
    ws.Range("B9") = DTPicker4.Value
    ws.Range("B10") = NameTextBox.Value


    'Bring Data Entry sheet back to front if necesary
    If chkBringToFront = False Then
        Sheets("DataEntry").Select
    End If

End Sub

Answer 1

由于您是VBA的新手，我给出了一个示例，该示例使用了您在编码未来（类和集合）中可能会发现有用的一些方面。

创建一个新类并将其命名为cTemplate。添加以下属性：

Public Original As Worksheet
Public Suffix As String

声明此模块级变量（即在程序的顶部）。

Private mTemplateList As Collection

使用模板对象填充集合。（注意我在一个名为“Initialise”的路由中完成了这个。如果你没有类似的东西，那么只需在你的Workbook_Open事件中调用这个例程。）

我更愿意控制模板名称，因此您会看到我已手动添加它们。但是，为了回答你的问题，我在它下面放了一个例程来读取工作表的第一行并取出模板名称，但它没有错误处理，如果在该列表中有任何改变，那么你的整个工作表命名结构会搞砸了。

Sub Initialise()
    '
    ' /.../
    '
    Dim template As cTemplate


    ' Populate the collection with template and clone names.
    Set mTemplateList = New Collection

    Set template = New cTemplate
    Set template.Original = ThisWorkbook.Worksheets("templateSavings")
    template.Suffix = "Savings"
    mTemplateList.Add template

    Set template = New cTemplate
    Set template.Original = ThisWorkbook.Worksheets("templateShares")
    template.Suffix = "Shares"
    mTemplateList.Add template

    Set template = New cTemplate
    Set template.Original = ThisWorkbook.Worksheets("templateStatements")
    template.Suffix = "Statements"
    mTemplateList.Add template

    '
    ' Or if you really must read a row of previous worksheet names
    ' and you are certain the first row contains "1" then sheet name,
    ' use the following
    '
    Dim rng As Range
    Dim cell As Range
    dim str as String

    Set mTemplateList = New Collection

    ' Quick and nasty row 1 selection -
    ' Adjust as you require for your own rows.
    Set rng = ThisWorkbook.Worksheets("Sheet1").UsedRange.Resize(1)

    ' Read each cell to obtain the template sheet name
    ' Assumes each name has "1" and "template" at the start
    For Each cell In rng.Columns
        Set template = New cTemplate
        str = Replace(cell.Text, "1", "")
        Set template.Original = ThisWorkbook.Worksheets(str)
        str = Replace(str, "template", "")
        template.Suffix = str
        mTemplateList.Add template
    Next

End Sub

最后，当用户添加新帐号时，请调用以下例程。

Sub CreateNewTemplates(accountNumber As Long)
    Dim template As cTemplate
    Dim accountPrefix As String
    Dim lastSheet As Worksheet

    ' Create prefix for worksheet names
    accountPrefix = Format(accountNumber, "00000")

    ' Loop through the templates to copy
    Set lastSheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    For Each template In mTemplateList

        template.Original.Copy After:=lastSheet
        ActiveSheet.Name = accountPrefix & template.Suffix
        Set lastSheet = ActiveSheet

    Next
End Sub

工作表对象需要仔细处理错误，并且您的例程需要检查重复的帐户名称，缺少模板等。这同样适用于行读取器的工作表名称。我担心我在晚上打字，我肚子上有一个婴儿，她只是在搅拌，所以我会为你留下这一点。

使用VBA

1 个答案: