Копирование динамических строк в новую книгу и сохранение его

Question

Я здесь новый. У меня есть поиск решения, но я могу найти именно то, что мне нужно.

Я нашел часть моего ответа на этот пост: Copying Dynamic Cells/Rows Into New Sheet or Workbook

Но есть 2 более конкретные действия, которые мне нужно, и я не могу понять это в хорошем смысле. Первое, что я хотел бы сохранить новые книги с именем «ключ» в том же месте, что и исходный файл. Вторая вещь - копировать также первую строку в каждую новую книгу. Вот мой пример: В моей БД, ключ сортируются так все альфа вместе и браво, а остальные ...

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

Вы могли бы сделать это как это (работал на моем компьютере для примера данных).не забудьте добавить майкрософт сценариев выполнения, чтобы сделать словарную работу:

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)

для SaveAs & Закрыть: (Excel VBA Open workbook, perform actions, save as, close)