Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Copiar dados de vár...
 
Notifications
Clear all

Copiar dados de vários arquivos .xls

 
2024 - VBA & Macros
Post Recente por VECHI 11 anos atrás
6 Posts
4 Usuários
0 Reactions
1,665 Visualizações
RSS
 DSimoes
(@dsimoes)
Posts: 11
Eminent Member
Topic starter
 

Boa tarde,

Pretendo copiar várias células de vários ficheiros excel que tenho num directório para uma planilha.

Exemplo:

Do ficheiro 20080003.xls quero copiar a celula G16 e copiar para a celula A1 da nova planilha, copiar a celula E22 e colocar na celula B1.
Do ficheiro 20080004.xls "" A2 "" B2.

Encontrei uma macro em outro forum, mas tenho alguns problemas:

Sub ImportarDados()
    Dim fs, f, f1, fc
    Dim Pasta As String
    Dim Coluna As Integer
    
    'Abre uma caixa de diálogo para possibilitar a seleção de uma pasta
    Application.FileDialog(msoFileDialogFolderPicker).Show
    Pasta = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(Pasta)
    Set fc = f.Files
    'Variável para controlar a coluna na qual será efetuada a cópia
    Coluna = 1
    For Each f1 In fc
        'Verifica a extensão do arquivo
        If Right(f1.Name, 3) = "xls" Then
            'Abre o arquivo Excel
            Workbooks.Open f1.Name
            'Seleciona a Plan1
            Sheets("Plan1").Select
            'Faz a cópia
            ActiveSheet.Range("G16").Copy ThisWorkbook.Sheets("Plan1").Cells(1, Coluna)
            'incrementa o número da coluna
            Coluna = Coluna + 1
            'Fecha o arquivo Excel
            Workbooks(f1.Name).Close SaveChanges:=False
        End If
    Next
End Sub

Esta macro funciona para mim, mas quando copia para a nova planilha em vez de ir adicionando linhas, adiciona colunas... Cola em A1,B1,C1... e quero em A1, A2, A3...

Outro problema quando a macro abre o ficheiro eu tenho de colocar sempre a mesma password, da para automatizar e colocar sempre a mesma?

Resumindo:

Quero adaptar esta macro para colocar os dados em varias linhas em vez de colunas.
Quero que ela copie mais que um dado.
Quero que ela coloque sempre a mesma password na caixa de dialogo que aparece quando abro os ficheiros.

Obrigado,
Diogo Simões

 
Postado : 23/03/2013 12:46 pm
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Boa noite!!

Já tenteou com o gravador de macros?

A variável Coluna tente inverter essa linha

ActiveSheet.Range("G16").Copy ThisWorkbook.Sheets("Plan1").Cells(1, Coluna)

Para

ActiveSheet.Range("G16").Copy ThisWorkbook.Sheets("Plan1").Cells(SuaVarivelAqui, 1)

Obs: Eu não testei sua rotina.

Att

 
Postado : 23/03/2013 5:07 pm
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Bom dia!!

Tente assim

Sub ImportarAleVBA()

    Dim file As String
    Dim Pasta As String
    Dim Linha As Integer
    Dim wb As Workbook
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show <> 0 Then
            Pasta = .SelectedItems(1) & ""
            Linha = 0
            file = Dir(Pasta & "*.xls")
            While file <> ""
                Linha = Linha + 1
                Set wb = Workbooks.Open(Pasta & file)
                wb.Sheets("Plan1").Range("G16").Copy ThisWorkbook.Sheets("Plan1").Cells(Linha, "A")
                wb.Sheets("Plan1").Range("E22").Copy ThisWorkbook.Sheets("Plan1").Cells(Linha, "B")
                wb.Close SaveChanges:=False
                file = Dir
            Wend
        End If
    End With
    
End Sub
 
Postado : 24/03/2013 7:29 am
 VECHI
(@vechi)
Posts: 2
New Member
 

Estou utilizando a mesma macro do colega Diogo Simões. Porém, como faço para executar o "colar especial valores" pois estou copiando valores que são fórmulas? Se alguém souber que comando utilizar na macro...

Obrigado

Paulo Vechi

 
Postado : 16/04/2014 11:39 am
 Wagner Morel
(@wagner-morel-vidal-nobre)
Posts: 4063
Famed Member
 

Assim:

    Range("C2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
Postado : 16/04/2014 1:31 pm
 VECHI
(@vechi)
Posts: 2
New Member
 

Obrigado Wagner

Porém o código ainda não funciona e preciso também incrementar a linha onde será colado os valores.

Sub ImportarDados()
    Application.ScreenUpdating = False
    Dim fs, f, f1, fc
    Dim Pasta As String
    Dim Linha As Integer
   
    'Abre uma caixa de diálogo para possibilitar a seleção de uma pasta
    Application.FileDialog(msoFileDialogFolderPicker).Show
    Pasta = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(Pasta)
    Set fc = f.Files
    'Variável para controlar a linha na qual será efetuada a cópia
    Linha = 2
    For Each f1 In fc
        'Verifica a extensão do arquivo
        If Right(f1.Name, 4) = "xlsx" Then
            'Abre o arquivo Excel
            Workbooks.Open f1.Name
            
            'Seleciona a Pasta origem
            Sheets("pasta origem").Select
            
            'Faz a cópia
            ActiveSheet.Range("Q77").Select
            Selection.Copy
            Windows("Arquivo destino.xlsm").Activate
            Range("E2").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

            'incrementa o número da coluna
            Linha = Linha + 1
            
            'Fecha o arquivo Excel
            Workbooks(f1.Name).Close SaveChanges:=False
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Atenciosamente

Paulo Vechi

 
Postado : 17/04/2014 6:34 am
Forum Jump:
  Tópico Anterior
Próximo Tópico