将由名称列表标识的工作表集合复制到新工作簿答案

【问题标题】：Copying collections of sheets identified by name list to new workbooks将由名称列表标识的工作表集合复制到新工作簿
【发布时间】：2018-06-05 23:10:49
【问题描述】：

我正在尝试将 Excel 工作簿中的特定集合表复制到单独的工作簿中。我不是 vba 编码器，我使用并改编了此处和其他资源站点中的代码。我相信我现在已经非常接近掌握了基本概念，但无法弄清楚我做错了什么，触发下面的代码会导致创建第一个新工作簿并插入第一张工作表，但此时会中断。

我的代码如下，附加相关信息 - 有一张名为“列表”的表格，其中有一列名称。列表中的每个名称都有 2 张纸，我试图将它们 2×2 复制到同名的新纸中。工作表被标记为名称和名称 + H（例如 Bobdata 和 BobdataH）

Sub SheetCreate()
'
'Creates an individual workbook for each worksname in the list of names.
'

Dim wbDest As Workbook
Dim wbSource As Workbook
Dim sht As Object
Dim strSavePath As String
Dim sname As String
Dim relativePath As String
Dim ListOfNames As Range, LRow As Long, Cell As Range
With ThisWorkbook
Set ListSh = .Sheets("List")
End With

LRow = ListSh.Cells(Rows.Count, "A").End(xlUp).Row '--Get last row of list.
Set ListOfNames = ListSh.Range("A1:A" & LRow) '--Qualify list.

With Application
    .ScreenUpdating = False '--Turn off flicker.
    .Calculation = xlCalculationManual '--Turn off calculations.
End With

Set wbSource = ActiveWorkbook

For Each Cell In ListOfNames


sname = Cell.Value & ".xls"
relativePath = wbSource.Path & "\" & sname

Sheets(Cell.Value).Copy
Set wbDest = ActiveWorkbook
Application.DisplayAlerts = False
ActiveWorkbook.CheckCompatibility = False
ActiveWorkbook.SaveAs Filename:=relativePath, FileFormat:=xlExcel8
Application.DisplayAlerts = True

wbSource.Activate
Sheets(Cell.Value & "H").Copy after:=Workbooks(relativePath).Sheets(Cell.Value)
wbDest.Save
wbDest.Close False
Next Cell

MsgBox "Done!"

End Sub

【问题讨论】：

您在哪一行遇到的具体错误是什么？
您好，在创建第一个新工作簿后出现“下标超出范围”
阅读minimal reproducible example 可能有助于改进您的帖子 - 请edit 您的问题提供所有相关信息，不要在 cmets 部分留下重要信息 ;-)

标签： excel vba

【解决方案1】：

你可以尝试改变

Sheets(Cell.Value & "H").Copy after:=Workbooks(relativePath).Sheets(Cell.Value)

到

Sheets(Cell.Value & "H").Copy after:=wbDest.Sheets(Cell.Value)

此外，最好检查文件是否已存在于所选位置。为此，您可以使用函数：

Private Function findFile(ByVal sFindPath As String, Optional sFileType = ".xlsx") As Boolean
Dim obj_fso As Object: Set obj_fso = CreateObject("Scripting.FileSystemObject")

findFile = False
findFile = obj_fso.FileExists(sFindPath & "/" & sFileType)

Set obj_fso = Nothing

End Function

并将 sFileType = ".xlsx" 更改为 "*" 或其他 excet 文件类型。

【讨论】：

谢谢，这有效，我也添加了签入。非常感谢，我会努力让我的基础知识更好！

【解决方案2】：

这是我创建的用于创建新工作簿并将工作表内容从现有工作簿复制到新工作簿的代码。希望对您有所帮助。

Private Sub CommandButton3_Click()
     On Error Resume Next
     Application.ScreenUpdating = False
     Application.DisplayAlerts = False
     TryAgain:
     Flname = InputBox("Enter File Name :", "Creating New File...")
     MsgBox Len(Flname)
     If Flname <> "" Then
    Set NewWkbk = Workbooks.Add
    ThisWorkbook.Sheets(1).Range("A1:J100").Copy
    NewWkbk.Sheets(1).Range("A1:J100").PasteSpecial
    Range("A1:J100").Select
    Selection.Columns.AutoFit
    AddData
    Dim FirstRow As Long
    Sheets("Sheet1").Range("A1").Value = "Data Recorded At-" & Format(Now(), "dd-mmmm-yy-h:mm:ss")
    NewWkbk.SaveAs ThisWorkbook.Path & "\" & Flname
    If Err.Number = 1004 Then
        NewWkbk.Close
        MsgBox "File Name Not Valid" & vbCrLf & vbCrLf & "Try Again."
        GoTo TryAgain
    End If
    MsgBox "Export Complete Close the Application."
    NewWkbk.Close
End If

结束子

【讨论】：