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”并根据上面的列表创建另一个工作簿对于Eg：

传真，Rax＆amp; Sax应该从“Report.xlsx”复制到新工作簿并将其重命名为Tom。像智者税应该被复制到一个新的工作簿，并将其重命名为Tami。并且应该将Max复制到新工作簿并将其重命名为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（工作簿）名称位于B列（带有col标头）< / p>

基于两个单元格值创建工作簿

1 个答案: