根據特定的列值，將單個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