excel - 单个 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中实现这个逻辑吗？零经验。先感谢您。

标签： excelvbakeyrow

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