Este fórum está sendo desativado

[daniexcel]

Boa tarde, sei que ja postei uma duvida similar... e foi atendida
No entanto, fuçando na internet, consegui me deparar com outras soluções, que acredito, possam auxiliar muitos usuarios do site

Achei dois codigos, mas nao consigo fazer com que funcionem.
Gostaria que se alguem pudesse ajudar, me auxiliasse em como corrigi-los


***********************************************
No primeiro codigo, eu indico a pasta origem dos arquivos. Ele deve fazer uma varredura em todos os arquivos com a extensao indicada e copiar/colar os valores das planilhas (o que não esta ocorrendo)

Código: Selecionar todos

Sub Abrir_Copiar_Colar()

Dim FSO As Object
Dim Pasta As String
Dim Planilha As Object
Dim OpenBook As String

Set FSO = CreateObject("Scripting.FileSystemObject")
Pasta = "C:\TESTE" 'Pasta com as planilhas que serão abertas e copiadas

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

For Each Planilha In FSO.GetFolder(Pasta).Files

If InStr(1, Planilha, ".xlsx") = 0 Then GoTo PRÓXIMO

Workbooks.Open (Planilha)
OpenBook = ActiveWorkbook.Name

'Seu código para copiar

Windows(ThisWorkbook.Name).Activate

'Seu código para colar

Application.CutCopyMode = False
Workbooks(OpenBook).Close False
PRÓXIMO:
Next

Application.ScreenUpdating = True

MsgBox "Dados Copiados com Sucesso!", vbInformation, "Aviso"

Application.Calculation = xlCalculationAutomatic

End Sub

***********************************************
No segundo codigo, atraves de uma opendialog, eu seleciono uma pasta e a macro deveria se encarregar de puxar as infos... o ideal é que puxasse todos os valores disponiveis (até a ultima linha) e fosse colando planilha embaixo de planilha.

Código: Selecionar todos

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) = "xlsx" Then
            'Abre o arquivo Excel
            Workbooks.Open f1.Name
            'Seleciona a Plan1
            Sheets("Plan1").Select
            'Faz a cópia
            ActiveSheet.Range("A1:A10").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

Se algum cranio ae conseguir ajudar, fico muitissimo grato

Obrigado desde ja
e bom final de semana

[Reinaldo]

Daniel, na primeira rotina toda a estrutura para selecionar uma pasta e "percorrer" os arquivos dessa pasta está montada.
O que falta :
--> 'Seu código para copiar /'Seu código para colar
--Abaixo dessa linha deve escrever / colar sua rotina de copia; no escopo da rotina inicial isso não está presente pois é algo, digamos assim, "pessoal"; ou seja cada um tem uma necessidade distinta.
Então defina o que deseja copiar de cada planilha, monte a rotina de copia e depois; estando funcionando; insira a rotina/macro nesse espaço.
O mesmo com o codigo para colar.

[daniexcel]

Reinaldo, bom dia
Eu inseri o codigo para copiar / colar nestes campos. Desculpe. acabei esquecendo de colar no codigo de meu post

Código: Selecionar todos

'Seu código para copiar

            Sheets("Plan1").Select
        Range("A2:w2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy



'Seu código para colar
            Sheets("Plan1").Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Range("A1").Select

Neste caso , ele deveria colar o intervalo de A2 a W2 das planilhas da pasta (selecionando até a ultima linha) e depois colar na minha pasta consolidada.
O problema é que o codigo não está funcionando direito e não sei onde estou errando
Poderia me ajudar?
obrigado

[Reinaldo]

não está funcionando direito

Então a priori funciona. Agora o que funciona e o que não atende.
O ideal seria dispor modelos/exemplos das planilhas, com o codigo "montado" para que possamos acompanhar a execução/propor solução

[daniexcel]

boa tarde Reinaldo
Segue anexo
o que eu quis dizer na verdade é que posso observar que a macro roda os arquivos (abre os que estão na pasta), mas não copia e cola os valores , como seria a intenção

[Reinaldo]

Experimente:

Código: Selecionar todos

Sub Abrir_Copiar_Colar()
Dim FSO As Object, Planilha As Object
Dim Pasta As String, OpenBook As String, EsteArquivo As String
Dim uLin As Long

'Determina o arquivo corrente/Ativo
EsteArquivo = ActiveWorkbook.Name
Set FSO = CreateObject("Scripting.FileSystemObject")
Pasta = ThisWorkbook.Path & "\01. Janeiro" 'Pasta com as planilhas que serão abertas e copiadas

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

For Each Planilha In FSO.GetFolder(Pasta).Files
    If InStr(1, Planilha, "xls") = 0 Then GoTo PRÓXIMO
        
    Workbooks.Open (Planilha)
    OpenBook = ActiveWorkbook.Name
        
    'Seu código para copiar
    Sheets("Plan1").Select
    Range("A2:w2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
        
    'Seu código para colar
    Windows(EsteArquivo).Activate
    Sheets("Plan1").Select
    'Determina qual a ultima linha com registro
    uLin = Cells(Cells.Rows.Count, "A").End(xlUp).Row
    'Seleciona a partir de qual celula (linha/coluna) os dados serão colados
    Range("A" & uLin + 1).Select
    'Cola valores
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    Application.CutCopyMode = True
    Workbooks(OpenBook).Close False
PRÓXIMO:
Next
Application.ScreenUpdating = True
MsgBox "Dados Copiados com Sucesso!", vbInformation, "Aviso"
Application.Calculation = xlCalculationAutomatic
End Sub

[daniexcel]

cara.. super obrigado
eu estava esquecendo de retornar para o arquivo e colar as informações pelo jeito né
Obrigadão mesmo
Acho que a macro 2 eu nem irei usar, pois esta já resolveu meu problema