將動態行復制到新工作簿並保存它

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）