Question

我是新来的。我已经找到了解决方案但我能找到我需要的东西。

我在这篇文章中找到了部分答案： Copying Dynamic Cells/Rows Into New Sheet or Workbook

但我需要更多具体行动，而且我无法以良好的方式解决这个问题。首先，我想在原始文件所在的位置保存名为“key”的新工作簿。第二件事是将第一行复制到每个新工作簿。这是我的例子：在我的数据库中，键被排序，所以所有的alpha都在一起，而bravo和其他的......

ORIGINAL DATABASE（DB）：

Name    Position    Key
Bruce   1           Alpha
Bruce   2           Alpha
Alfred  2           Alpha
Alfred  3           Bravo
Robin   1           Bravo
Robin   1           Bravo

在我想要的第一本工作簿中：

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

此VBA工作正常，但每次都不复制第一行而不保存。我有大约400个“键”，因此手动处理变得困难。我根本不是专家。

您能否在答案中复制完整的代码，以便我能够弄明白？预先感谢您的帮助。我读了很多帖子，你总是想出来帮助别人。所以，谢谢你。

你可能已经明白英语不是我的第一语言。抱歉错误和错误的语法。

提前感谢！

Answer 1

你可以这样做（在我的电脑上用于数据示例）。记得添加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

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

for dictionary：（Does VBA have Dictionary Structure?）

表示自动过滤：（VBA for filtering columns）

for SaveAs＆amp;关闭：（Excel VBA Open workbook, perform actions, save as, close）

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

1 个答案: