Usuário com melhor resposta
Copiar dados de uma planilha fechada (origem) para uma planilha aberta (destino)

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.
Respostas
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
-
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. -
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
-
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.
-
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
-
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
-
"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
-
-
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
-
-
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
-