根据条件将工作表合并到新工作簿中并保存

Question

我有一个由 100 多个工作表组成的工作簿。这些工作表在工作表的名称中有帐号/姓名/日期。

工作表的命名约定遵循 AccountNumber/AccountName/Description 的这种模式：

11-Greg-Monday
11-Greg-Tuesday
11-Greg-Friday
38-Rachel-Sunday
38-Rachel-Tuesday
38-Rachel-Saturday

我希望 Excel 循环遍历所有工作表，提取所有 11-Greg 工作表并保存到名为 11-Greg 的新工作簿中，然后对 38-Rachel 等执行相同操作。我有一个列表工作簿中名为“Accounts”的工作表上的帐号/名称。

是否可以在提取工作表后保留公式，并像列宽一样进行格式化？

我发现这段代码可以开始工作，但我不知道如何引用“帐户”选项卡上的列表来循环访问帐户名称？

Dim wb as Workbook, sht as WorkSheet
Dim strFileName As String

'Copy sheet as a new workbook
ActiveWorkbook.Sheets("Sheet1").Copy

Set wb = ActiveWorkbook
Set sht = wb.Sheets(1)

'SaveAs
strFileName = Application.GetSaveAsFilename(wb.Name) & "xlsx"
If strFileName = "False" Then Exit Sub 'User Canceled
wb.SaveAs Filename:=strFileName

Answer 1

最简单的方法是创建一个您想要堆叠在单独列表中的名称列表。将该列表设置为范围，然后遍历每个单元格检查以查看工作表名称的 x 字母是否匹配。像这样的

   Sub stacksheets()
Dim rng As Range, cCell As Range
Dim ws As Worksheet
Dim wb As Workbook, wb2 As Workbook
Dim shName As String

Set rng = ActiveWorkbook.Sheets("list").Range("a1:a2") ''this would be the list of names
Set wb2 = ActiveWorkbook ''remembering activeworkbook so can return


For Each cCell In rng
    shName = Left(cCell.Value, 5) ''this needs to be the minimum letters from each name that is unique
    Set wb = Workbooks.Add

    For Each ws In wb2.Sheets
        If InStr(ws.Name, shName) > 0 Then ''checks for name in sheet name
            ws.Copy after:=wb.Sheets(1)
            wb2.Activate
        End If
    Next ws
    wb.SaveAs (wb2.Path & "\" & cCell.Value) '' saves workbook as list name

Next cCell

End Sub