Notifications
Clear all

Atualizar 17 arq. xls em um xls. que ñ é exatamente igual

7 Posts
3 Usuários
0 Reactions
1,338 Visualizações
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Olá,

Tenho 17 arquivos xls., atualmente, de igual teor, com itens para colocar OK. Bem simples.
E um arquivo mãe que não é exatamente igual , exemplo de 200 itens que possue nela, 100 são iguais aos demais 17 arq..
Preciso manter arquivo mãe atualizado baseado nos 17 outros arquivos.
Neste momento abro um atualizo, abro o mãe e atualizo, trabalho duplo, isso quando dá tempo de fazer os dois.
O que eu preciso é :
Ao atualizar um arquivo (entre os 17) e automaticamente atualizar a planilha mãe.

 
Postado : 29/05/2012 7:20 am
(@robert)
Posts: 561
Honorable Member
 

Boa tarde,Andrea!

Não sei se entendi bem a sua necessidade mais poderá víncular planilha por planilha. É um trabalho chatinho mais vale a pena, o problema é saber como estar seu layout para poder fazer isso.

:D

 
Postado : 29/05/2012 10:05 am
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Layout dos 17 arquivos entre si sao iguais.
todos eles possuem os mesmos itens para dar ok.
Cada arquivo contem uma unica planilha, usada por tres meses e depois nunca mais.

O Layout arquivo mãe não, ele possue itens iguais(aos dos 17 arquivos) que precisam ser dado ok, e itens diferentes.
Este arquivo também só possue uma planilha, e é eterna.

Criar um vínculo célula a célula não me facilitaria nada.
Criar um vínculo com o Word tambem não, porque só trabalho com excel em ambos.
Não tenho como alterar os layout´s pois o arquivo mãe, possue outras informações.

 
Postado : 29/05/2012 12:22 pm
(@benzadeus)
Posts: 78
Trusted Member
 

Os itens estão dispostos num formato de tabela? Se sim, você pode criar uma rotina na Pasta de Trabalho mãe que faz um laço em todas as Pastas de Trabalho, concatena os dados de todos as outras 17 Pastas de Trabalho, em seguida filtra apenas registros únicos.
Para o exemplo abaixo, não se esqueça de adicionar a referência à biblioteca Microsoft ActiveX Data Objects 2.0 ou superior. Considere que as 17 Pastas de Trabalho estão na mesma pasta e a Pasta de Trabalho mestre numa Planilha diferente:

Private Sub Exemplo()
    Dim fld As Object
    Dim fl As Object
    Dim ws As Worksheet
    Dim wsResultados As Worksheet
    
    'Considere que as Pastas de Trabalho estão na mesma pasta.
    'Mude o caminho da pasta abaixo para o desejado:
    Set fld = CreateObject("Scripting.FileSystemObject").GetFolder("c:temp")
    
    Set ws = ThisWorkbook.Sheets.Add
    ws.Range("A1:D1") = Array("Campo1", "Campo2", "Campo3", "Campo4")
    For Each fl In fld.Files
        If Extensão(fl.Name) = "xls" Then
            SQL "SELECT * FROM [Plan1$]", ws.Cells(RowLast(ws.Columns("A")), "A").Offset(1), False, False, fl.Path
        End If
    Next fl
    Set wsResultados = Sheets.Add
    'A consulta abaixo é para mostrar apenas registros distintos da primeira lista criada:
    SQL "SELECT DISTINCT * FROM [" & ws.Name & "$]", wsResultados.Range("A1"), True, True, ThisWorkbook.FullName
    Application.DisplayAlerts = False
    ws.Delete
    Application.DisplayAlerts = True
    
End Sub

Function RowLast(rng As Range) As Long
    'Retorna o valor da última linha povoada do intervalo rng
    With rng
        On Error Resume Next
        RowLast = .Find(What:="*" _
          , After:=.Cells(1) _
          , SearchDirection:=xlPrevious _
          , SearchOrder:=xlByColumns _
          , LookIn:=xlFormulas).Row
        If RowLast = 0 Then RowLast = rng.Cells(1).Row
    End With
End Function

Private Function Extensão(s As String) As String
    'Retorna extensão de um arquivo em letras minúsculas.
    'Pode gerar exceção se arquivo não possuir exceção.
    Extensão = LCase(Mid(s, InStrRev(s, ".") + 1))
End Function

Private Sub SQL(sSQL As String, _
               Optional rng As Range, _
               Optional bTemCabeçalho As Boolean = True, _
               Optional bApagarCampos As Boolean = True, _
               Optional sWorkbook As String)
'Faz uma consulta SQL e num intervalo, numa Planilha chamada wsTemp.
'Se bTemCabeçalho = True, significa que os cabeçalhos serão gravados no intervalo ou variant de saída.
'Se bApagarCampos = True, o intervalo de largura igual ao número de recordsets de saída serão apagados
'pelo método ClearContents.
'Para funcionar, é necessário adicionar a referência Microsoft ActiveX Data Objects 2.0 ou superior
    
    Dim lng As Long
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    
    Set cn = New ADODB.Connection
    Set rs = New ADODB.Recordset
    
    If Val(Application.Version) < 12 Then 'Para Excel 97-2003
        cn.ConnectionString = _
          "Provider=Microsoft.Jet.OLEDB.4.0;" & _
          "Data Source=" & sWorkbook & ";" & _
          "Extended Properties=Excel 8.0;"
        cn.Open
    Else 'Para Excel 2007 ou 2010
        cn.ConnectionString = _
          "Provider=Microsoft.ACE.OLEDB.12.0;" & _
          "Data Source=" & sWorkbook & ";" & _
          "Extended Properties=Excel 8.0"
        cn.Open
    End If
    
    Set rs = cn.Execute(sSQL)
    
    If bApagarCampos Then
        rng.Resize(, rs.Fields.Count).EntireColumn.ClearContents
    End If
    If bTemCabeçalho Then
        For lng = 0 To rs.Fields.Count - 1
            rng.Offset(, lng) = rs.Fields(lng).Name
        Next lng
        Set rng = rng.Offset(1)
    End If
    
    rng.CopyFromRecordset rs
    
    rs.Close
    cn.Close
End Sub
 
Postado : 29/05/2012 8:26 pm
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Boa noite!!

Olá Andrea Flach, quando for postar, faça no fórum correspondente ao seu título!!

Seu tópico será movimentado!!

Att

 
Postado : 29/05/2012 8:37 pm
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Justamente pra isso que o postei aqui. Porque eu não sabia onde posta-lo.

 
Postado : 01/06/2012 8:20 am
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Mas agradeço por movimenta-lo.

 
Postado : 01/06/2012 8:28 am