Excel 将动态行复制到新工作簿并保存

我是新来的。我一直在寻找解决方案，但我能找到我真正需要的

我在这篇文章中找到了部分答案：

但我还需要另外两个具体的行动，我无法很好地解决这个问题。 首先，我想用“key”的名称将新工作簿保存在原始文件所在的位置。 第二件事是把第一行也抄到每一本新的作业本上。 以下是我的例子： 在我的数据库中，键被排序，所以所有的alpha都在一起，bravo和其他

原始数据库（DB）：

在第一份工作簿中，我希望：

Name    Position   Key
Bruce   1          Alpha
Bruce   2          Alpha
Alfred  2          Alpha

我希望这个工作簿保存为“Alpha.xlsx”，与原始数据库（在桌面上的一个文件中）在同一个目录中，然后他关闭窗口

那么第二个工作簿将是

Name    Position  Key
Alfred  3         Bravo
Robin   1         Bravo
Robin   1         Bravo

以“Bravo.xlsx”的名称保存在我桌面上的同一个文件中，然后关闭并继续使用400键

下面是我在论坛上找到的帖子中的代码： 原始代码是由chiliNUT编写的我进行了更新以适应我的数据库

Sub grabber()
Dim thisWorkbook As Workbook
Set thisWorkbook = ActiveWorkbook
last = 1
For i = 1 To 564336 'my DB had 500K rows
If Range("A" & i) <> Range("A" & (i + 1)) Then
Range("A" & last & ":N" & i).Copy
Set NewBook = Workbooks.Add
NewBook.Sheets("Feuil1").Range("A1").PasteSpecial xlPasteValues
last = i + 1
thisWorkbook.Activate
End If
Next i
End Sub

Sub-grabber（）
将此工作簿设置为工作簿
设置thisWorkbook=ActiveWorkbook
最后=1
对于i=1至564336'而言，我的数据库有500K行
如果范围（“A”&i）范围（“A”&i+1”），则
范围（“A”&最后一个&“：N”&i）。复制
Set NewBook=工作簿。添加
NewBook.Sheets（“Feuil1”）.范围（“A1”）.粘贴特殊XLPaste值
last=i+1
此工作簿。激活
如果结束
接下来我
端接头

这个VBA工作得很好，但它不会每次都复制第一行，也不会保存它。我有大约400把“钥匙”，所以很难手动操作。 我根本不是专家

你能在你的答案中复制完整的代码吗？这样我就能猜出来了？ 提前感谢您的帮助。 我读了很多帖子，你总是想办法帮助别人。所以也谢谢你

你可能明白英语不是我的第一语言。对不起，语法错误

提前感谢

您可以这样做（在我的pc上使用数据示例）。请记住添加microsoft脚本运行时以使字典正常工作：

Sub grabber()
    Dim thisWs As Worksheet: Set thisWs = ActiveWorkbook.ActiveSheet
    'To make dictionaries work, and the line to make sense, you need to reference Microsoft Scripting Runtime, Tools-> References, and check of "Microsoft Scripting Runtime"
    Dim myDict As New Scripting.Dictionary
    Dim pathToNewWb As String
    Dim currentPath, columnWithKey, numCols, numRows, uniqueKeys, uKey

    'to avoid the screenupdating being false in case of unforseen errors, I want the program to jump to unfreeze if errors occur
    On Error GoTo unfreeze 

    'with 400 keys it would end up with a lot of flicker + speeds it up:
    Application.ScreenUpdating = False


    'get the path of the active workbook
    currentPath = Application.ActiveWorkbook.Path

    'I hardcode the reference to the key column
    columnWithKey = 3
    'And assume that the worksheet is "just" data, why the number of used rows and columns can be used to identify the data
    numCols = thisWs.UsedRange.Columns.Count


    'extract the index of the last used row in the active sheet of the active workbook
    numRows = thisWs.UsedRange.Rows.Count

    'use a dictionary to get a list of unique keys by running over the key column in the used rows
    For i = 2 To numRows
        vKey = thisWs.Cells(i, columnWithKey)
        If Not myDict.exists(vKey) Then
            myDict.Add vKey, 1
        End If
    Next i

    uniqueKeys = myDict.keys()

    For Each uKey In uniqueKeys
        pathToNewWb = currentPath & "/" & uKey & ".xlsx"

        'Filter the keys column for a unique key
        thisWs.Range(thisWs.Cells(1, 1), thisWs.Cells(numRows, numCols)).AutoFilter field:=columnWithKey, Criteria1:=uKey

        'copy the sheet
        thisWs.UsedRange.Copy

        'Open a new workbook, chang the sheets(1) name and paste as values, before saveas and close
        Set NewBook = Workbooks.Add
        With NewBook
            .Sheets(1).Name = "Feuil1"
            .Sheets(1).Range("A1").PasteSpecial xlPasteValues
            .SaveAs pathToNewWb
            .Close
        End With

        'remove autofilter (paranoid parrot)
        thisWs.AutoFilterMode = False

    Next

    Set myDict = Nothing

unfreeze:
    Application.ScreenUpdating = True

End Sub

在修改您提供的代码时，我使用了以下帖子：

对于字典：（）

对于自动筛选：（）

---

对于SaveAs&Close:（）

每次我都被你们打动了。似乎没有问题没有答案给你！非常感谢。但是有一件事我做不到，那就是在“工具”选项卡中激活引用。它是灰色的，我没有权限，所以我不能尝试你的杰作。有什么线索吗？可能有点太复杂了（至少对我来说），因为我尝试了我引用的第一个代码，它似乎可以完成这项工作，即使有400个键。所以我的问题是，如果你有时间，你能不能告诉我SaveAs操作的名称是第3列，并且你的代码是否每次都会为每个“提取”复制第一行？`如果你没有时间，谢谢你的回答，我会尝试找出它关于灰显的引用，你不能处于调试模式。如果问题在未调试时仍然存在，我将没有答案。代码复制每次迭代的标题。代码对键列应用过滤器，复制整个工作表并粘贴为值。结果是，只有未过滤掉的值才会粘贴到新工作簿中。新工作簿的名称在pathToNewWb中设置，它只是一个字符串，由原始工作簿的路径和唯一键组合而成。尝试添加一些断点并检查局部变量（查看->局部变量窗口）Saveas操作与Save As功能非常相似，而不是通过弹出窗口（fileDialog）手动选择，您只需准确地告诉它文件的放置位置（例如C:/“something”/Alpha.xlsx，其中“C:/”something“部分是您原始工作簿的目录）亲爱的Andreas，感谢您抽出时间回答我的问题，它在我的示例（10万行）中非常有效。在我的最终清单上，我还有一些工作要做，我将很快尝试。它可能会工作（如果我有困难，我会写在这里，我想）！再次感谢你，祝你晚上好

Sub grabber()
    Dim thisWs As Worksheet: Set thisWs = ActiveWorkbook.ActiveSheet
    'To make dictionaries work, and the line to make sense, you need to reference Microsoft Scripting Runtime, Tools-> References, and check of "Microsoft Scripting Runtime"
    Dim myDict As New Scripting.Dictionary
    Dim pathToNewWb As String
    Dim currentPath, columnWithKey, numCols, numRows, uniqueKeys, uKey

    'to avoid the screenupdating being false in case of unforseen errors, I want the program to jump to unfreeze if errors occur
    On Error GoTo unfreeze 

    'with 400 keys it would end up with a lot of flicker + speeds it up:
    Application.ScreenUpdating = False


    'get the path of the active workbook
    currentPath = Application.ActiveWorkbook.Path

    'I hardcode the reference to the key column
    columnWithKey = 3
    'And assume that the worksheet is "just" data, why the number of used rows and columns can be used to identify the data
    numCols = thisWs.UsedRange.Columns.Count


    'extract the index of the last used row in the active sheet of the active workbook
    numRows = thisWs.UsedRange.Rows.Count

    'use a dictionary to get a list of unique keys by running over the key column in the used rows
    For i = 2 To numRows
        vKey = thisWs.Cells(i, columnWithKey)
        If Not myDict.exists(vKey) Then
            myDict.Add vKey, 1
        End If
    Next i

    uniqueKeys = myDict.keys()

    For Each uKey In uniqueKeys
        pathToNewWb = currentPath & "/" & uKey & ".xlsx"

        'Filter the keys column for a unique key
        thisWs.Range(thisWs.Cells(1, 1), thisWs.Cells(numRows, numCols)).AutoFilter field:=columnWithKey, Criteria1:=uKey

        'copy the sheet
        thisWs.UsedRange.Copy

        'Open a new workbook, chang the sheets(1) name and paste as values, before saveas and close
        Set NewBook = Workbooks.Add
        With NewBook
            .Sheets(1).Name = "Feuil1"
            .Sheets(1).Range("A1").PasteSpecial xlPasteValues
            .SaveAs pathToNewWb
            .Close
        End With

        'remove autofilter (paranoid parrot)
        thisWs.AutoFilterMode = False

    Next

    Set myDict = Nothing

unfreeze:
    Application.ScreenUpdating = True

End Sub