Question

我有一本有两张纸的工作簿。 “公司”工作表具有动态行，并具有设置的列A-J。

在“表-摘要”工作表中，我具有唯一公司名称的摘要，并且使用代码从“公司”工作表中的b列获取唯一名称。在“表格摘要”表中，人们可以分配给唯一的公司，并根据个人分配给哪些公司来分配表。在“表格-摘要”表的第3栏中输入个人的姓名。

我有一些代码，它根据在“表-摘要”表中的单元格（LastRow，3）中输入的内容来创建工作表。分配给多家公司的个人超过10个人，具体取决于分配人在C列中输入的名称。请参见图片。我不想为每个受让人创建重复的工作表。我做了一个谷歌搜索的建议，例如一个功能，它检查工作表是否存在，但不知道它在做什么。如果我也能获得帮助。请，谢谢。

我如何告诉VBA检查“表-摘要”表中的b列，以复制并粘贴具有“公司”表b列中的客户名称的行。并将其放入受让人的相应工作表中。

我是VBA的新手。如果我不清楚。 P租赁让我知道

Sub GetAssignedCompanies()
    Dim wbMaster As Workbook
    Dim shI As Worksheet
    Dim shS As Worksheet

    Set wbMaster = Workbooks("Workbook1.xlsx")
    Set shI = wbMaster.Worksheets("Companies")
    Set shS = wbMaster.Worksheets("Table - Summary")

    Dim LastRow As Integer
    Dim EndRow As Integer
    Dim aName As String

    LastRow = 4
    EndRow = 2
    While Len(shS.Cells(LastRow, 2).Value) > 0
        aName = shS.Cells(LastRow, 3).Value

        If Not aName = vbNullString Then
            Sheets.Add(After:=Sheets(Sheets.count)).Name = aName
        End If

        LastRow = LastRow + 1
    Wend
End Sub

Answer 1

这是一个例子；在运行此宏之前，您需要为每个员工创建新的工作表；它将公司名称从“表-摘要”第1列写入员工工作表的第1列。根据需要更改员工工作表的名称。

'You need to create the individual worksheet before running this macro.
Dim nameShtArr, i As Long, shS As Worksheet, shI As Worksheet

Set shI = ThisWorkbook.Worksheets("Companies")
Set shS = ThisWorkbook.Worksheets("Summary")

nameShtArr = Array("Tom", "Bob", "Joe")

    For i = LBound(nameShtArr) To UBound(nameShtArr)
        With shS.Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row)
            .AutoFilter Field:=1, Criteria1:=nameShtArr(i)
        End With

        'Place the company names assigned to the employee in column A.
        shS.Range("B2:B20").SpecialCells(xlCellTypeVisible).Copy Worksheets(nameShtArr(i)).Range("A1")

        'This next section will loop through each company name in the current worksheet and find it in ColB,
        'if it finds the company name it will copy the data in the row to ColJ and paste it into the current worksheet.
        Dim lRow As Long
        lRow = Worksheets(nameShtArr(i)).Range("A" & Rows.Count).End(xlUp).Row

            For Each Cel In Sheets(nameShtArr(i)).Range("A1:A" & lRow)
                Dim fndCel As Range
                Set fndCel = shI.Range("B:B").Find(Cel.Value)
                    If Not fndCel Is Nothing Then
                        fndCel.Offset(, 1).Resize(, 10).Copy Cel.Offset(, 1)
                    End If
            Next Cel
    Next i

    shS.Cells.AutoFilter

如何基于表输入在一行中复制和粘贴值并将其粘贴到动态工作表名称中

1 个答案: