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

Question

我是新来的。我有一个解决方案，但我可以找到我需要的东西。

，我发现我的答案的一部分，在这个帖子： Copying Dynamic Cells/Rows Into New Sheet or Workbook

但有2个，我需要更具体的行动，我不能弄明白的一个好办法。 首先我想将新工作簿与“原始文件”的名称保存在原始文件的相同位置。 第二件事是将第一行复制到每个新的工作簿。 这里我举的例子： 在我的数据库，重点进行排序，这样所有的字母都在一起，布拉沃和休息...

原始数据库（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我做了更新，以适应我的DB

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 

在适应您提供的代码，我用下面的帖子：

的字典：（Does VBA have Dictionary Structure?）

的自动筛选：（ VBA for filtering columns）

为另存为&关闭：（Excel VBA Open workbook, perform actions, save as, close）