根据列值将 Excel 2010 电子表格拆分为多个工作簿文件

Question

我找到并清理了大量按国家/地区分类的联系人数据，目前我使用 Excel 进行管理。主要是因为这样清理和操作我找到的数据更容易，而且我可以轻松地与同事分享每个国家/地区的数据。目前有多个按国家/地区组织的工作簿（因为我们总共有大约 280,000 个联系人，将它们放在一个工作簿中很麻烦）。

所以文件夹结构是

Argentina
Australia
Austria
etc...

每个都包含一个名为

国家名称.xlsx

我有另一个“仪表板”电子表格，报告每个单独工作簿的总数以及联系人细分总数。

工作簿的格式大致如下

澳大利亚.xls

Country          Department      Name            Email               Telephone          
Australia        Finance         John Doe        [email protected]      07..
Australia        Admin           Jane Doe        [email protected]      07..
Australia        Sales           Bill Pond       [email protected]      07..
etc...

大约有 28 个列描述符。

我想要的是有一个工作簿，比如说：

工作进度.xlsx

当我向其中添加数据时，一旦保存，数据就会自动添加到每个国家的工作簿中，从而保留所有列。然后我可以将其清除并每天重新开始，因为我知道数据是按国家/地区存储的。

Excel 2010 中是否有任何功能可以自动执行此操作，或者这是否需要 VBA（我怀疑它会）？

Answer 1

我知道这已经很老了，但作为参考：

Option Explicit

Private Const Q         As String = "'"
Private Const ROOT      As String = "E:\Test\"
Private Const FLDR      As String = "SubFolder"
Private Const DASHBRD   As String = "Db.xlsx"

Public Sub updateAllFiles()
    Dim ws As Worksheet, cn As ADODB.Connection, rs As ADODB.Recordset, sql As String
    Dim fs As Variant, updateVals As String, rng As Range, allFiles As Long, i As Long
    Dim fld As Variant, cName As String

    fs = fileListFSO    'fileListXL
    allFiles = UBound(fs)
    If allFiles > -1 Then
        Set ws = Worksheets(1)
        Set rng = ws.UsedRange.Rows(ws.UsedRange.Rows.Count)

        rng.Replace Q, """" 'remove single quotes (')
        updateVals = Join(Application.Transpose(Application.Transpose(rng)), Q & "," & Q)
        updateVals = Replace(Replace(updateVals, "[", vbNullString), "]", vbNullString)
        updateVals = Q & updateVals & Q
        Set cn = New ADODB.Connection: Set rs = New ADODB.Recordset

        For i = 0 To allFiles
            cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & fs(i) & ";" & _
                    "Extended Properties=""Excel 12.0"";"

            sql = "Select * From [Sheet1$]"
            rs.Open sql, cn, adOpenStatic, adLockReadOnly, adCmdText: rs.Close

            sql = "INSERT INTO [Sheet1$] Values " & "(" & updateVals & ")"
            rs.Open sql, cn, adOpenStatic, adLockReadOnly, adCmdText: cn.Close
        Next
        Set rs = Nothing: Set cn = Nothing
    End If
End Sub

。

这些函数返回具有完全限定文件名（完整路径）的一维数组

Private Function fileListFSO(Optional ByVal fldrPath As String = ROOT & FLDR) As Variant
    Dim fso As Variant, FLDR As Variant, f As Variant, result As Variant
    If Len(Dir(fldrPath, vbDirectory)) > 0 Then
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set FLDR = fso.GetFolder(fldrPath)
        For Each f In FLDR.Files
            If InStr(f.Name, "~$") = 0 And InStr(f.Name, ".xlsm") = 0 Then
                result = result & f.Path & ","
            End If
        Next
        fileListFSO = Split(Left(result, Len(result) - 1), ",")
    End If
End Function



Private Function fileListXL(Optional ByVal xlFile As String = ROOT & DASHBRD) As Variant
    Dim wb As Workbook, ws As Worksheet, result As Variant
    If Len(Dir(xlFile)) > 0 Then
        Set wb = Workbooks.Open(Filename:=xlFile, ReadOnly:=True)
        Set ws = wb.Worksheets(1)
        result = Join(Application.Transpose(ws.UsedRange.Columns(1)), ",")  'col to str
        fileListXL = Split(result, ",")                                     'str to arr
        wb.Close
    End If
End Function

。

更新文件：

测试文件：

测试文件 - 之前：

测试文件-之后：

。

笔记：

• 所有要更新的文件应位于同一文件夹中
• 所有文件（包括更新程序）应具有完全相同的格式（相同的列数）
• 所有更新的文件（包括更新程序）都应包含第一张表上的数据，名为“Sheet1”
• 所有更新的文件的数据都应格式化为文本（用于 ADO Insert 语句）

• DashBoard 文件 (db.xlsx) 应在名为“Sheet1”的工作表的 A 列中列出所有文件

  • 所有文件都应包含完整路径