首页 文章

Excel VBA - 复制模板工作表并链接单元格和命名表

提问于
浏览 次
0

我在工作表中的A列中有数据名为“摘要” . 有几个月它有50行，而有时它有500行 .

我有一个名为“模板”的模板表 . 我想创建一个“模板”表的副本，在Summary的每一行之后命名它（这样一个循环），然后将行单元格数据放在工作表的单元格A1中 . 最后回到摘要表中，我想在指向工作表的行中创建一个超链接 .

这是我希望它的样子的图像：
enter image description here

excel vba

2 回答

  • 1

    在Excel中玩弄一些后，我相信这将满足您的需求 . 只需放入一个新模块并执行即可 .

    Sub CreateLinkedSheets()

    Dim rngCreateSheets As Range
    Dim oCell As Range

    Dim oTemplate As Worksheet
    Dim oSummary As Worksheet
    Dim oDest As Worksheet

    Set oTemplate = Worksheets("Template")
    Set oSummary = Worksheets("Summary")
    Set rngCreateSheets = Worksheets("Summary").Range("A1", Range("A1").End(xlDown))
    'Above line assumes NO blank cells in your list of school supplies

    For Each oCell In rngCreateSheets.Cells

        oTemplate.Copy After:=Worksheets(Sheets.Count)
        Set oDest = ActiveSheet
        oDest.Name = oCell.Value

        oDest.Range("A1").Value = oCell.Value

        oSummary.Hyperlinks.Add Anchor:=oCell, Address:="", SubAddress:= _
            oDest.Name & "!A1", TextToDisplay:=oDest.Name
    Next oCell

End Sub

    我坚持使用macro recorder首先检查代码输出然后根据您的需要进行调整 . 这就是我为获取添加超链接的代码所做的工作 .

    要使此代码生效，您的工作表必须命名为"Summary"和"Template"（如图片中所示），并且A列中的列表必须是连续的，也就是说您不能在列表中留下任何空白单元格 . 如果你这样做了 Set rngCreateSheets = Worksheets("Summary").Range("A1", Range("A1").End(xlDown)) 赢了't set the range properly and you'将丢失物品 .

    回复于
  • 0

    搜索将为您提供大量答案，尤其是在Stackoverflow上 . 以下是我搜索过的一些示例，也许它会对您有所帮助 .

    我知道已经发布了一个答案，但由于我已经有了一些东西，并且它略有不同，我想我会发布它，因为它有一些额外的功能，你可以从中收集 . 这包括：

    • 错误检查（如果存在相同名称的工作表）

    • 子例程在传递变量时作为单独例程中的调用

    尝试一下，让我知道你的想法 .

    Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
 'Created by Tim Williams from Stackoverflow.com
 'https://stackoverflow.com/questions/6688131/excel-vba-how-to-test-if-sheet-exists
    Dim sht As Worksheet

     If wb Is Nothing Then Set wb = ThisWorkbook
     On Error Resume Next
     Set sht = wb.Sheets(shtName)
     On Error GoTo 0
     SheetExists = Not sht Is Nothing
 End Function

Sub CreateSummarySheets(SummaryWS As Worksheet, TemplateWS As Worksheet)

    Dim newWS As Worksheet
    Dim rCell As Range
    Dim lastRow As Long
    Dim answer  As Long

    lastRow = SummaryWS.Cells(Rows.Count, "A").End(xlUp).Row

    For Each rCell In SummaryWS.Range("$A$1:$A$" & lastRow)
      'Add copy of template
        TemplateWS.Copy After:=Sheets(Sheets.Count)
        Set newWS = Sheets(Sheets.Count)

      'Sheet exists error checking
        answer = 1
        If SheetExists(newWS.Name) = False Then
            answer = vbNo
            answer = MsgBox("Sheet with the name " & rCell.Value & " already exists.  Delete it?", vbYesNo, rCell.Value & " Sheet Exists")
        End If

        If answer = vbYes Then
            Sheets(rCell.Value).Delete
        End If
        If answer = 1 Or answer = vbYes Then
            newWS.Name = rCell.Value
        End If

      'Populate newWS's cell A1
        newWS.Cells(1, "A") = rCell.Value
      'Add Hyperlink from summary to newWS
        newWS.Hyperlinks.Add Anchor:=rCell, Address:="", _
            SubAddress:="'" & newWS.Name & "'" & "!A1", TextToDisplay:=newWS.Name
    Next rCell

End Sub

Sub test()
    Dim s_ws As Worksheet
    Set s_ws = Sheets("Summary")

  'Two ways to run this function
    Call CreateSummarySheets(s_ws, Sheets("Template"))
End Sub
    回复于

相关问题