Chia bảng tính excel 2010 thành nhiều tệp sổ làm việc dựa trên giá trị cột

Tôi tìm và xóa rất nhiều dữ liệu liên hệ, được sắp xếp theo quốc gia mà tôi hiện đang sử dụng excel để quản lý. Chủ yếu là vì việc dọn dẹp và thao tác dữ liệu tôi tìm thấy theo cách này dễ dàng hơn và tôi có thể dễ dàng chia sẻ dữ liệu của từng quốc gia với các đồng nghiệp của mình. Hiện tại có nhiều sổ làm việc được tổ chức theo quốc gia (vì chúng tôi có tổng cộng khoảng 280.000 liên hệ và có chúng trong một sổ làm việc là không hiệu quả).

Vì vậy, cấu trúc thư mục là

Argentina
Australia
Austria
etc...

Mỗi bảng chứa một bảng tính được gọi là

tên quốc gia.xlsx

Tôi có một bảng tính 'bảng điều khiển' khác báo cáo tổng số từ mỗi sổ làm việc riêng lẻ cùng với tổng số phân đoạn liên hệ.

Định dạng cho sổ làm việc là một cái gì đó dọc theo dòng

Úc.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...

Có khoảng 28 mô tả cột.

Những gì tôi muốn xảy ra là có một bảng tính, nói:

Workinprowards.xlsx

Và khi tôi thêm dữ liệu vào đây, nó sẽ tự động được thêm vào sổ làm việc của mỗi quốc gia sau khi được lưu, bảo toàn tất cả các cột. Sau đó tôi có thể xóa sạch nó và bắt đầu làm mới mỗi ngày khi biết dữ liệu đang được lưu trữ theo quốc gia.

Có bất kỳ chức năng nào có thể làm điều này tự động trong Excel 2010 không, hoặc điều này sẽ yêu cầu VBA (như tôi nghi ngờ nó sẽ làm)?

Tôi biết điều này là cũ, nhưng như một tài liệu tham khảo:

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

.

Các hàm này trả về mảng 1 chiều với tên tệp đủ điều kiện (đường dẫn đầy đủ)

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

.

Đang cập nhật tệp:

Kiểm tra tập tin:

Kiểm tra tệp - Trước:

Kiểm tra tệp - Sau:

.

Ghi chú:

• Tất cả các tệp được cập nhật phải nằm trong cùng một thư mục
• Tất cả các tệp (bao gồm trình cập nhật) phải có cùng định dạng (cùng số lượng cột)
• Tất cả các tệp được cập nhật (bao gồm trình cập nhật) phải có dữ liệu trên trang tính đầu tiên, được đặt tên là "Trang tính 1"
• Tất cả các tệp được cập nhật phải có dữ liệu được định dạng là Văn bản (đối với câu lệnh Chèn ADO)

• Tệp DashBoard (db.xlsx) phải có danh sách tất cả các tệp trong cột A, trên một trang có tên "Sheet1"

  • Tất cả các tệp phải bao gồm đường dẫn đầy đủ