От одного листа Excel до нескольких листов на основе определенного значения столбца

Question

У меня следующая проблема:

У меня есть электронная таблица типа:

Field1    Field2     Field3    Field4
NameA     AddressA   KeyA      ValueA
NameB     AddressB   KeyA      ValueB
NameD     AddressD   KeyA      ValueD
NameE     AddressE   KeyB      ValueE
NameC     AddressC   KeyB      ValueC
NameF     AddressF   KeyC      ValueF
.... (200k entries)

Я хотел бы прочитать рабочий лист и создать несколько отдельных рабочих книг Excel, содержащих только один рабочий лист, каждый из которых будет содержать:

Workbook1/Sheet1: (Workbookname ie KeyA.xlsx)
Field1    Field2     Field3    Field4
NameA     AddressA   KeyA      ValueA
NameB     AddressB   KeyA      ValueB
NameD     AddressD   KeyA      ValueD

Workbook2/Sheet1: (Workbookname ie KeyB.xlsx)
Field1    Field2     Field3    Field4
NameC     AddressC   KeyB      ValueC
NameE     AddressE   KeyB      ValueE

Workbook3/Sheet1: (Workbookname ie KeyC.xlsx)
Field1    Field2     Field3    Field4
NameF     AddressF   KeyC      ValueF

Первая строка должна существовать во всех созданных рабочих книгах. Их значения Field3 отсортированы, это логика, которую я имел в c:

main(excel_file)
{
   open(excel_file, r)
   header = read(excel_file)
   first_line = true

   while not eof(excel_file)
  {
  line_cur = read(excel_file)

  if first_line
  {
     office = get_office(line_cur)
     office_file = open(name=office, w)

     write(office_file, header)
     write(office_file, line_cur)

     line_prv = line_cur
     first_line = false
     continue
  }

  office_cur = get_office(line_cur)
  office_prv = get_office(line_prv)

  // If same group.
  if office_cur = office_prv
  {
     write(office_file, line_cur)

     line_prv = line_cur
     continue
  }

  // If different group.
  if office_cur != office_prv
  {
     close(office_file)
     office_file = open(name=office_cur, w)

     write(office_file, header)
     write(office_file, line_cur)

     line_prv = line_cur
     continue
  }
   }   // while end.

   close(office_file)
   close(excel_file)
}

Не могли бы вы, ребята, помочь мне понять, как реализовать эту логику в VBA? Ноль опыта в этом. Заранее спасибо.

Answer 1

Из ваших примеров данных (с использованием ActiveSheet) это создает 3 файла по текущему пути

KeyA.xlsx
KeyB.xlsx
KeyC.xlsx

---

Option Explicit

Public Sub GenerateKeyFiles()
    Const K_COL = "C"

    Dim ws As Worksheet:    Set ws = ActiveSheet
    Dim ur As Range:        Set ur = ws.UsedRange
    Dim ck As Range:        Set ck = ur.Columns(K_COL)
    Dim arr As Variant:     arr = ck.Offset(1)
    Dim d As Object:        Set d = CreateObject("Scripting.Dictionary")

    Dim itm As Variant, i As Long, wbp As String
    For Each itm In arr
        If Len(itm) > 0 Then d(itm) = 0
    Next
    Dim wbX As Workbook:    Set wbX = Workbooks.Add
    Dim wsX As Worksheet:   Set wsX = wbX.Worksheets(1):    wbp = ThisWorkbook.Path & "\"

    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    For i = 2 To wbX.Worksheets.Count
        wbX.Worksheets(i).Delete
    Next

    If ws.AutoFilterMode Then ur.AutoFilter
    For Each itm In d
        ck.AutoFilter Field:=1, Criteria1:=itm
        ur.Copy
        wsX.Cells(1).PasteSpecial xlPasteColumnWidths
        wsX.Cells(1).PasteSpecial xlPasteAll:   wsX.Cells(1).Select
        wsX.SaveAs wbp & itm, Excel.XlFileFormat.xlOpenXMLWorkbook
        wsX.UsedRange.Clear
    Next
    wbX.Close SaveChanges:=False:       ur.AutoFilter
    Application.DisplayAlerts = True:   Application.ScreenUpdating = True
End Sub

---

Main.xlsm

KeyA.xlsx

KeyB.xlsx

KeyC.xlsx