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

Question

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.

Answer 1

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

Answer 2

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.

Answer 3

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

Answer 4

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.

Answer 5

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

Answer 6

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

Answer 7

"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

Answer 8

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.

Answer 9

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

Answer 10

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

Answer 11

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

Answer 12

cosegui usando:

ActiveSheet.Range("A1").Copy

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