none
Copiar dados de uma planilha fechada (origem) para uma planilha aberta (destino) RRS feed

  • Pergunta

  • boa tarde

    Gostaria de adaptar o codigo abaixo para copiar varios dados da planilha Gestão (aba Banco) para a planilha Total (aba Banco)

    Sub ReadDataFromAllWorkbooksInFolder()
        Dim FolderName As String, wbName As String, cValue As Variant
        Dim wbList As String, sValuePlan4 As String
        
            'Path (Diretorio) -Ajustar o Caminho
            FolderName = "C:\Users\Jota\Desktop"
            
                'Nome do Arquivo de onde extrairemos a informação
                wbName = Dir(FolderName & "\" & "GESTÃO.xls")
                'Armazenamos nas Variaveis
                wbList = wbName
                wbName = Dir
            
                'le o Valor no workbook
                cValue = GetInfoFromClosedFile(FolderName, wbList, "Banco", "A2:Z8") ' ou até a ultima celula preenchida
                
                'Msgbox com o Valor em A1
                MsgBox "O Valor em A2 - Plan4 é :- " & cValue
                
                'Armazenamos o Valor na variavel
                sValuePlan4 = cValue
                
                'Coloca o Valor na Celula
                Cells(1, 1).Formula = cValue
    
    End Sub
    
        Private Function GetInfoFromClosedFile(ByVal wbPath As String, _
                                                wbName As String, _
                                                wsName As String, _
                                                cellRef As String) As Variant
        
        Dim arg As String
            GetInfoFromClosedFile = ""
            
            If Right(wbPath, 1) <> "\" Then wbPath = wbPath & "\"
            
            If Dir(wbPath & "\" & wbName) = "" Then Exit Function
            
                arg = "'" & wbPath & "[" & wbName & "]" & _
                    wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
            
            On Error Resume Next
            GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
            
        End Function

    Detalhe:

    As colunas I, U até Z são formulas automaticamente criadas atraves de macros a medida em que vamos inserindo dados atraves de from.

    Obrigado.

    domingo, 29 de dezembro de 2013 20:39

Respostas

  • cosegui usando:

    ActiveSheet.Range("A1").Copy

    Obrigado pela atenção mais uma vez Filipe (Benzadeus).

    • Marcado como Resposta JLNunes quarta-feira, 1 de janeiro de 2014 18:07
    quarta-feira, 1 de janeiro de 2014 18:06

Todas as Respostas

  • Usando esse método, creio não ser possível copiar um intervalo de uma vez pelo método ExecuteExcel4Macro, ou seja, você teria que copiar célula por célula e isso demoraria muito.

    Outra alternativa é fazer uma consulta SQL na pasta de trabalho que está fechada, mas existe o requisito da planilha de consulta estar em formato de tabela, com cabeçalhos na linha 1, sem linhas e colunas em branco, etc. para uma boa compatibilidade na instrução.

    Pergunta: é realmente necessário que as pastas de trabalho estejam fechadas para você realizar seu processo?


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    segunda-feira, 30 de dezembro de 2013 13:49
    Moderador
  • Boa noite

    Muito bem,

    Outra alternativa é fazer uma consulta SQL na pasta de trabalho que está fechada, mas existe o requisito da planilha de consulta estar em formato de tabela

    com cabeçalhos na linha 1,

    sem linhas e colunas em branco. refere-se ao cabeçalhos ou a todas linhas e colunas?

    a planilha destino será igual a planilha origem, porem, tem linha e ciluna em branco, conforme imagem anexo:

     é realmente necessário que as pastas de trabalho estejam fechadas para você realizar seu processo?

    da planilha Gestão (origem) tem muitos codigo em VBA em formularios, e ao abrir sobrepõe outros arquivos.

    segue alguma macros que temos no arquivo:

    ao fechar o arquivo

    Private Sub Fechar_Programa_Click()
    Unload Agenda
    PROTEGER
     Dim Resp
        Resp = MsgBox("Deseja Salvar As Alterações Feitas no Programa Gestão ?", vbYesNo + vbExclamation)
        If Resp = vbYes Then
        Sheets("Apresentação").Visible = True
        Sheets("Apresentação").Select
        ActiveWindow.DisplayWorkbookTabs = True
        Application.DisplayFormulaBar = True
        ThisWorkbook.Save
        ThisWorkbook.Close
        'ActiveWorkbook.Save
        'ActiveWorkbook.Close
        'Application.Quit
        '''Workbooks("BOOK1.XLS").Close SaveChanges:=False
        Else
        Sheets("Apresentação").Visible = True
        Sheets("Apresentação").Select
        ActiveWindow.DisplayWorkbookTabs = True
        Application.DisplayFormulaBar = True
        ThisWorkbook.Saved = True
        ThisWorkbook.Close
        'ActiveWorkbook.Close
        End If
    'ActiveWorkbook.Save
    'ActiveWorkbook.Close
    End Sub

    ao abrir o arquivo

    'FORMULARIO EM TELA CHEIA
    Private Declare Function GetSystemMetrics32 Lib "user32" _
        Alias "GetSystemMetrics" (ByVal nIndex&) As Long
    
    'FORMULARIO EM TELA CHEIA
    Private Sub UserForm_Initialize()
        Dim nFator As Single
        nFator = 0.75
        Me.Width = GetSystemMetrics32(0) * nFator
        Me.Height = GetSystemMetrics32(1) * nFator
    End Sub

    obrigado.
    segunda-feira, 30 de dezembro de 2013 23:05
  • Entendi. Em outras palavras, em outras palavras, a pasta de trabalho Gestão possui eventos que são disparados ao abri-la.

    Você pode suprimir a execução de eventos no Excel facilmente, basta utilizar a sintaxe:

    Sub fnc()
      Application.EnableEvents = False
      
      'código aqui
      
      Application.EnableEvents = True
    End Sub

    Note que nesse caso, se você obter um erro no código e interromper a execução de uma macro, você terá que habilitar novamente os eventos digitando, por exemplo, na janela de verificação imediata o código Application.EnableEvents = True e então pressionando Enter. Alternativamente, você pode reiniciar o Excel para habilitar novamente os eventos.

    ---

    Se não me engano, já te mostre como faz um código que abre uma pasta de trabalho e copia informações de uma planilha para outra. Sabe como fazer agora que os eventos foram desabilitados?


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    terça-feira, 31 de dezembro de 2013 11:28
    Moderador
  • boa tarde

    "em outras palavras, a pasta de trabalho Gestão possui eventos que são disparados ao abri-la."

    Uso este codigo em EstaPasta_de_Trabalho

    Private Sub Workbook_Open()
    Application.ScreenUpdating = False
    Dim barras
        On Error Resume Next
    'Oculta todos os Menus (Ribbons)
      Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",False)"
    
    For Each barras In Application.CommandBars
        barras.Enabled = True
    Next
        Application.WindowState = xlMaximized
        Application.CommandBars("Standard").Visible = False
        Application.CommandBars("Formatting").Visible = False
        Application.CommandBars("Worksheet Menu Bar").Enabled = False 'False AAA
        Application.CommandBars("drawing").Visible = False
        Application.CommandBars("Web").Visible = False
        'Application.DisplayFullScreen = True
        ActiveWindow.DisplayHeadings = False
        Application.DisplayFormulaBar = False
        ActiveWindow.DisplayHorizontalScrollBar = False
        ActiveWindow.DisplayVerticalScrollBar = True 'False
        ActiveWindow.DisplayWorkbookTabs = False
        Application.DisplayStatusBar = False
        Call RetiraXdaBarra
        
        
     Plan3.Unprotect Password:="123"
     Plan3.Activate
     Range("A2:A65000").Select
      Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Range("Y18").Select
    Plan3.Unprotect Password:="HGESF"
    ActiveWindow.DisplayWorkbookTabs = False
    Sheets("Apoio").Select
    On Error Resume Next
    'Incluir novos Leitos
    V = 1
    For X = 2 To 43
     If Sheets("Apoio").Cells(X + 1, 23) = "V" Or Sheets("Apoio").Cells(X + 1, 23) = "v" Then
      V = V + 1
     End If
    Next X
    C = Format(Date, "mm"): LI = Format(Date, "dd")
    C = CStr(C) * 1 + 8: LI = CStr(LI) * 1 + 1
     For Z2 = C To 20
      For Z1 = LI To 32
       Sheets("Apoio").Cells(Z1, Z2) = V
      Next Z1
      LI = 2
     Next Z2
    
    'Application.Visible = Not Application.Visible
    Sheets("Apresentação").Visible = True
    Sheets("Apresentação").Select
    Plan3.Protect Password:="123"
    PROTEGER
    'Application.ScreenUpdating = True
    Agenda.Show
    Application.ScreenUpdating = True
    End Sub
    
    Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.ScreenUpdating = False
    Dim barras
    'Exibe todos os Menus (Ribbons)
      Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"
    
    For Each barras In Application.CommandBars
        barras.Enabled = True
    Next
        Application.WindowState = xlMaximized
        Application.CommandBars("Standard").Visible = True
        Application.CommandBars("Formatting").Visible = True
        Application.CommandBars("Worksheet Menu Bar").Enabled = True
        Application.CommandBars("drawing").Visible = True
        Application.CommandBars("Web").Visible = False
        Application.DisplayStatusBar = True
        Application.DisplayFormulaBar = True
        Application.DisplayFullScreen = False
        ActiveWindow.DisplayHeadings = False 'True
        ActiveWindow.DisplayHorizontalScrollBar = True
        ActiveWindow.DisplayVerticalScrollBar = True
        ActiveWindow.DisplayWorkbookTabs = True
        Call RepoeXdaBarra
        Application.Quit
    Application.ScreenUpdating = True
    End Sub

    E na aba Banco uso este codigo

    Private Sub Worksheet_Activate()
    Dim rngSelection    As Range
    Dim lRow            As Long
    Dim lCol            As Long
        
        If TypeName(Selection) = "Range" Then Set rngSelection = Selection
        With ActiveWindow
            lRow = .ScrollRow
            lCol = .ScrollColumn
            .ScrollRow = 1
            .ScrollColumn = 1
            ActiveSheet.Range("A1:K1").Select
            .Zoom = True
            .ScrollRow = lRow
            .ScrollColumn = lCol
        End With
        
        If Not rngSelection Is Nothing Then
            rngSelection.Select
            Set rngSelection = Nothing
        End If
    End Sub

    "Se não me engano, já te mostre como faz um código que abre uma pasta de trabalho e copia..."

    Desculpe-me, não lembro o codigo, talvez tenha sido outro membro, mais tudo bem.

    Como seria o codigo para as tentativas?

    Obrigado.

    terça-feira, 31 de dezembro de 2013 15:47
  • Veja o tópico a seguir: http://social.msdn.microsoft.com/Forums/pt-BR/957b4c81-0c73-42cb-8ff5-cbb3fee8bf53/macro-para-copiar-e-colar-em-outra-planilha?forum=vbapt

    No entanto, não se esqueça de desabilitar os eventos antes e habilitá-los depois novamente!


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    terça-feira, 31 de dezembro de 2013 21:49
    Moderador
  • boa noite

    Tentei adaptar o codigo para as minhas necessidade mais ocorre um problema:

    Sub fnc()
      Application.EnableEvents = False
      Dim wkbOrigem As Excel.Workbook
      Dim wksOrigem As Excel.Worksheet
      Dim wkbDest As Excel.Workbook
      Dim wksDest As Excel.Worksheet
      Dim lngLast As Long
      
      'Abre pastas de trabalho e planilhas.
      'Altere os caminhos e nomes de planilhas para adequar a seu caso.
      Set wkbOrigem = Workbooks.Open("C:\Users\Jota\Desktop\GESTÃO.xls")
      Set wksOrigem = wkbOrigem.Worksheets("Banco")
      Set wkbDest = Workbooks.Open("C:\Users\Jota\Desktop\Total.xls")
      Set wksDest = wkbDest.Worksheets("Banco")
      
      With wksOrigem
        lngLast = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
      End With
          
      'Se quiser colar valores:
      wksOrigem.Range("A2:Z" & lngLast).Copy
      wksDest.Range("A2:Z" & lngLast).PasteSpecial Paste:=xlPasteValues
      
      wkbOrigem.Close SaveChanges:=False
      'wkbDest.Close SaveChanges:=True
      Application.EnableEvents = True
    End Sub

    Set wkbDest = Workbooks.Open("C:\Users\Jota\Desktop\Total.xls")

    Set wksDest = wkbDest.Worksheets("Banco")

    A palnilha Total encontra-se aberta, no codigo acima pergunta se quer reabri-la.

    Se reabrir nao faz o procedimento correto.

    Se nao reabrir aparece uma mensagem de erro:

    Erro em tempo de execuçao '1004'

    Erro de definição no aplicativo ou de definição no objeto.

    Obrigado.

    Feliz Ano Novo a todos. Vamos comemorar
    • Editado JLNunes terça-feira, 31 de dezembro de 2013 23:06
    terça-feira, 31 de dezembro de 2013 23:03
  • "A palnilha Total encontra-se aberta, no codigo acima pergunta se quer reabri-la."

    Troque

    Set wkbDest = Workbooks.Open("C:\Users\Jota\Desktop\Total.xls")

    por:

    Set wkbDest = Workbooks("C:\Users\Jota\Desktop\Total.xls")

    ---


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    quarta-feira, 1 de janeiro de 2014 00:33
    Moderador
  • bom dia

    apresentou um erro:

    usando o depurador F8:

    Erro de Tempo de Execução 9:

    Subscrito Fora do Intervalo

    nesta linha

    Set wkbDest = Workbooks("C:\Users\Jota\Desktop\Total.xls")

    Obrigado.

    quarta-feira, 1 de janeiro de 2014 15:07
  • Desculpa, falha minha.

    Ainda com a pasta de trabalho aberta, o correto seria:

    Set wkbDest = Workbooks("Total.xls")

    Não é necessário especificar o caminho completo da pasta de trabalho quando está aberta no Excel.


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    quarta-feira, 1 de janeiro de 2014 16:36
    Moderador
  • boa

    funcionou 100%, porém, so um inconveniente, apareçe a mensagem:

    Há muita informação na area de transferencia...

    . Para salva-las....

    . Para exclui-las....

    Sim    Não   Cancelar

    quarta-feira, 1 de janeiro de 2014 17:29
  • Desabilite os alertas momentaneamente apenas para fechar a pasta de trabalho:

    Application.DisplayAlerts = False
    wkb.Close SaveChanges=True 'ou True
    Application.DisplayAlerts = True


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    quarta-feira, 1 de janeiro de 2014 17:39
    Moderador
  • cosegui usando:

    ActiveSheet.Range("A1").Copy

    Obrigado pela atenção mais uma vez Filipe (Benzadeus).

    • Marcado como Resposta JLNunes quarta-feira, 1 de janeiro de 2014 18:07
    quarta-feira, 1 de janeiro de 2014 18:06