根据 Master sheet 中的 ID 创建新工作表并复制数据答案

【问题标题】：Create new sheets and copy data according to the ID in Master sheet根据 Master sheet 中的 ID 创建新工作表并复制数据
【发布时间】：2021-10-08 07:43:48
【问题描述】：

我有一张客户表，格式如下，格式为 ListObject - Customer。根据下表，应在“客户”选项卡中根据客户数量创建新工作表。

Customer ID	Customer Name	Description	Location
Customer1	John Doe	test1	USA
Customer2	Heather Novak	test2	UK
Customer3	Allison Parker	test3	GE

根据上表，应创建 3 个工作表，分别称为 Customer1、Customer2 和 Customer3。这些新工作表是模板的副本，如下所示：

蓝色单元格是标题，是模板表的一部分
灰色单元格为空白，应根据工作表名称复制主工作表中的数据。我添加了单元格的引用（它总是一样的）

所有工作表的理想输出应如下所示：

我能够创建一个宏来创建工作表并相应地命名它们，但我无法管理将数据从整行传输到特定单元格。

Option Explicit

Sub SheetsFromTemplate()
Dim wsMASTER As Worksheet, wsTEMP As Worksheet
Dim shNAMES As Range, Nm As Range

With ThisWorkbook
    Set wsTEMP = .Sheets("Template")                                'sheet to be copied
    Set wsMASTER = .Sheets("Customers")              'sheet with names
    Set shNAMES = wsMASTER.Range("Customers[Customer ID]")  'range to find names to be checked
    
    Application.ScreenUpdating = False
    For Each Nm In shNAMES
            wsTEMP.Copy After:=.Sheets(.Sheets.Count)
            ActiveSheet.Name = CStr("Customer " & Nm.Text)
    Next Nm
    
   Application.ScreenUpdating = True                           'update screen one time at the end
End With

MsgBox "All sheets created"
End Sub

你能告诉我，如何相应地动态地复制和转置数据吗？

非常感谢！

【问题讨论】：

标签： excel vba

【解决方案1】：

根据表格中的挂件命名模板中的所有灰色字段。用下划线替换单词间距（例如 Customer_ID）。命名单元格时请务必选择模板而不是工作簿本身。

那么就可以使用下面的代码了：

Sub SheetsFromTemplate()

Dim wsMASTER As Worksheet, wsTEMP As Worksheet, wsCustomer As Worksheet
Dim loMaster As ListObject

With ThisWorkbook
    Set wsTEMP = .Sheets("Template")                                'sheet to be copied
    Set wsMASTER = .Sheets("Customers")              'sheet with names
    
    Set loMaster = wsMASTER.ListObjects("Customer")
    
    Dim r As Range, Customer As String
    Dim lc As ListColumn
    
    Application.ScreenUpdating = False
    
    For Each r In loMaster.DataBodyRange.Rows
        Customer = r.Cells(1, 1)
        wsTEMP.Copy After:=.Sheets(.Sheets.Count)
        Set wsCustomer = ActiveSheet
        
        With wsCustomer
            .Name = Customer
            
            For Each lc In loMaster.ListColumns
                'Assumption: per each list column there is a named range on the sheet
                'empty spaces in column names are replaced by an underscore in range name
                .Range(Replace(lc.Name, " ", "_")) = Intersect(lc.DataBodyRange, r)
            Next
        End With
    Next
   Application.ScreenUpdating = True                           'update screen one time at the end
End With

MsgBox "All sheets created"
End Sub

代码在列表对象的所有行中移动（第一个 for-each）

每行创建一个新工作表并根据第一个单元格命名。

然后通过将字段名称映射到列表列名称来将值写入每个灰色字段。（每个第二个）

通过将 listcolumn-range 与第一个 for-each-loop 中的行相交，可以找到 customer-table 中的相关值。

【讨论】：