根据两个单元格创建工作簿

Question

我有一个工作簿" report.xlsx"，其中有70张（所有70张纸的名称都在一个工作簿中的名为" list.xlsx"的列表中）。现在，我需要根据" list.xlsx"中的列表创建工作簿。

我有一个像这样的列表。

Sheet Name  Person name
Fax            Tom
Tax            Tami
Rax            Tom
Max            Sara
Sax            Tom

我需要的是一个可以移动工作簿" report.xlsx"的代码，并根据上述列表创建另一个工作簿例如：

传真，rax＆amp;SAX应复制到" Report.xlsx"的新工作簿中，并将其更名为Tom。像明智的税款一样，应将其复制到新的工作簿中，并将其更名为tami。同样的最大值应复制到新的工作簿中，并将其更名为Sara。

感谢您提前的所有帮助。

---

亲爱的团队，

以下是我尝试过的代码，但是我仍然无法获得我需要的东西，任何人都可以帮忙。

Sub Copysheets()
Dim thisWB  As String
Dim newWB As String
Dim endofprocess As String
Dim m As Integer
        thisWB = ActiveWorkbook.Name
        On Error Resume Next
         Application.DisplayAlerts = False
        Sheets("tempsheet").Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
        Sheets.Add
        ActiveSheet.Name = "tempsheet"
        Sheets("list").Select
        If ActiveSheet.AutoFilterMode Then
            Cells.Select
            On Error Resume Next
            ActiveSheet.ShowAllData
            On Error GoTo 0
    End If
    Columns("A:C").Select
    Selection.Copy
    Sheets("tempsheet").Select
    Range("A1").Select
    ActiveSheet.Paste
    Columns("b").Delete
    Application.CutCopyMode = False
        If (Cells(1, 1) = "") Then
            LastRowx = Cells(1, 1).End(xlDown).Row
            If LastRowx <> Rows.Count Then
                Range("A1:A" & LastRowx - 1).Select
                Selection.Delete Shift:=xlUp
            End If
        End If
    Cells.Select
    Selection.Sort _
            Key1:=Range("b2"), Order1:=xlAscending, _
            Header:=xlYes, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
    lMaxSupp = Cells(Rows.Count, 1).End(xlUp).Row
    For suppno = 2 To lMaxSupp
    Windows(thisWB).Activate
    supname = Sheets("tempsheet").Range("B" & suppno)

        If supname <> "" Then
        Workbooks.Add
        ActiveWorkbook.SaveAs "Balance Sheet Review - " & supname
            newWB = "Balance Sheet Review - " & supname
        Windows("Balance Sheet Review Dec 13 - APJ.xlsm").Activate
For i = 2 To 100
Windows(""Report.xlsx"").Activate
Worksheets("tempsheet").Activate
            FldrName = Left(Cells(i, 1).Value, 30)
            Worksheets(FldrName).Activate
            Sheets(FldrName).Select
           Sheets(FldrName).Copy Before:=Workbooks( _
        newWB & ".xlsx").Sheets(1)

Next i

        End If
    Next

End Sub

Answer 1

尝试将以下代码放入您的list.xlsx中。您编写的代码似乎没有做到，所以我重写了整个内容：

Sub Test()
Dim twb As Workbook
Dim nwb As Workbook
Dim rpt As Workbook
Dim tws As Worksheet
Dim sh As Worksheet
Dim bcnt As Integer
Dim wbn As String
Dim wsn As String
Dim wsexist As Boolean
Dim createnwb As Boolean
Dim SFile as string
Dim Spath as string

Set twb = ThisWorkbook ' list.xlsx
Set tws = twb.Sheets("list") ' assume your worksheet called list in list.xlsx
Spath = "C:" ' or where your source files stored
SFile = Dir(Spath & "*.xlsx") 
do while len(Sfile) > 0
Set rpt = Workbooks.Open(Spath & SFile) 'or where the file sits
twb.Activate
tws.Activate
Range("A1", Range("B1").End(xlDown)).Select
bcnt = Selection.Count
Selection.Sort _
            Key1:=Range("b2"), Order1:=xlAscending, _
            Header:=xlYes, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal

For i = 2 To bcnt
    wbn = Cells(i, 2).Value
    wsn = Cells(i, 1).Value
    wsexist = False
    createnwb = False
    If Cells(i, 2).Value <> Cells(i - 1, 2).Value Then
        createnwb = True
    End If
    rpt.Activate
    For Each sh In Worksheets
        If sh.Name = wsn Then
            If createnwb = True Then
                Set nwb = Workbooks.Add()
            End If
            'rpt.Activate
            sh.Copy before:=nwb.Sheets(1)
            wsexist = True
            Exit For
        End If
    Next sh
    twb.Activate
        If wsexist = True Then
            If Cells(i, 2).Value <> Cells(i + 1, 2).Value Then
            nwb.SaveAs Filename:="C:" & wbn
            nwb.Close
            End If
        End If
Next i
SFile = Dir
Loop
End Sub

自定义带有您的本地路径/文件名等。它基于您的样本，其中表名称位于A列（带有Col标头）和 Person（Workbook）名称位于B列（带有Col标头）