Dividindo uma planilha do Excel 2010 em vários arquivos de pasta de trabalho com base no valor da coluna

Question

Eu localizo e limpo muitos dados de contato, classificados por país, que estou usando no momento para gerenciar. Principalmente porque é mais fácil limpar e manipular os dados que encontro dessa maneira, e posso compartilhar facilmente os dados de cada país com meus colegas. Atualmente, existem várias pastas de trabalho organizadas por país (já que temos cerca de 280.000 contatos no total e tê-los em uma pasta de trabalho é difícil).

Portanto, a estrutura da pasta é

Argentina
Australia
Austria
etc...

Cada um contendo uma planilha chamada

countryname.xlsx

Eu tenho outra planilha de 'painel' informando os totais de cada pasta de trabalho individual junto com os totais de segmentação de contato.

O formato da pasta de trabalho é algo nos moldes de

Australia.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...

Existem cerca de 28 descritores de coluna.

O que eu gostaria de ter é ter uma pasta de trabalho, por exemplo:

Workinprogress.xlsx

E à medida que eu adiciono dados a isso, ele é automaticamente adicionado à pasta de trabalho de cada país, uma vez salvo, preservando todas as colunas. Posso limpá-lo e começar de novo todos os dias sabendo que os dados estão sendo armazenados por país.

Existe alguma funcionalidade que pode fazer isso automaticamente no Excel 2010, ou isso exigirá o VBA (como eu suspeito que seja)?

    

Answer 1

Eu sei que isso é antigo, mas como referência:

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

.

Essas funções retornam uma matriz unidimensional com nomes de arquivos completos (caminho completo)

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

.

Atualizando arquivo:

Arquivosdeteste:

Arquivosdeteste-antes:

Arquivosdeteste-depois:

.

Notas:

• Todososarquivosaserematualizadosdevemestarnamesmapasta
• Todososarquivos(incluindooatualizador)devemterexatamenteomesmoformato(mesmonúmerodecolunas)
• Todososarquivosatualizados(incluindooatualizador)devemterosdadosdaprimeiraplanilha,denominados"Planilha1"
• Todos os arquivos atualizados devem ter os dados formatados como Texto (para a instrução ADO Insert)

• O arquivo DashBoard (db.xlsx) deve ter uma lista de todos os arquivos na coluna A, em uma planilha chamada "Sheet1"

  • Todos os arquivos devem incluir o caminho completo