Разделение электронной таблицы Excel 2010 на несколько файлов рабочих книг на основе значения столбца

Question

Я нахожу и очищаю много контактных данных, отсортированных по странам, которыми в настоящее время пользуюсь Excel для управления. В основном потому, что данные, которые я нахожу, легче очищать и манипулировать ими, и я легко могу поделиться данными каждой страны со своими коллегами. В настоящее время существует несколько рабочих книг, организованных по странам (поскольку у нас в общей сложности около 280 000 контактов, и иметь их в одной рабочей книге громоздко).

Таким образом, структура папок

Argentina
Australia
Austria
etc...

Каждый из них содержит таблицу под названием

countryname.xlsx

У меня есть еще одна электронная таблица «Личный кабинет», в которой представлены итоги по каждой отдельной книге, а также итоги сегментации контактов.

Формат книги - что-то вроде

Australia.xls

Country          Department      Name            Email               Telephone          
Australia        Finance         John Doe        test@test1.com      07..
Australia        Admin           Jane Doe        test@test2.com      07..
Australia        Sales           Bill Pond       test@test3.com      07..
etc...

Есть около 28 дескрипторов столбцов.

Я хотел бы, чтобы у меня была одна рабочая тетрадь:

Workinprogress.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) должен иметь список всех файлов в столбце A на листе с именем "Sheet1"

  • Все файлы должны включать полный путь