[Resolvido]Abrir, editar a planilha em excel e fecha-lo no VBA no Access

Senhores

Ja tentei um monte de coisa e não consigo,

Ja utilizei o Workbooks.Open e tambem o GetObject(VarArquivo)

Mas so da erro...

Alguem sabe como me ajudar?

O que preciso mesmo é.

1- Verificar se o arquivo excel existe na pasta
2 - abrir o arquivo excel (Pode ser somente Leitura, pois não poderei salvar o arquivo)
3 - Colocar uma informação no campo C16 que esta num formulario no access
4 - imprimir o arquivo
5 - Fechar o arquivo sem salvar

Alguem pode me ajudar?

Pessoal

Acabei eu mesmo encontrando uma solução...

se puder ajudar alguem... segue abaixo

Dim VarArquivo As String
Dim rpt As Report
Dim xlsApp As Excel.Application
Dim xlsBook As Excel.Workbook
Dim xls As Excel.Worksheet


VarArquivo = CurrentProject.Path & "\Formularios\FOR CO LOG 001 - Check List de InspeçãoV26.xlsm"

Set xlsBook = Workbooks.Open(VarArquivo, , True)
Set xlsApp = xlsBook.Parent
Set xls = xlsApp.Sheets("Plan1")

xlsApp.visible = True
xlsBook.Application.Cells(16, 3).Value = "Esta é a coluna c16"


não esqueça de ativar o excel na biblioteca

abraços

Olá amigo,

Eu usei seu código mas não funcionou aqui. Não entendi sobre a parte de ativar Excel na biblioteca.

Poderia postar algum exemplo aqui ou detalhar um pouco mais como fazer?

Grato.

Mestre Avelino,

Obrigado mais uma vez pela ajuda!

Funcionou.

Bom dia,

Avelino ou colegas do Fórum! Será que conseguem ver um código para ler todos os arquivos no formato XLS e XLSX de uma pasta e incluir uma informação em uma range (P1:P200)?
Tentei mexer nesse código ai, mas não estou conseguindo.

Dim VarArquivo As String
Dim rpt As Report
Dim xlsApp As Excel.Application
Dim xlsBook As Excel.Workbook
Dim xls As Excel.Worksheet


VarArquivo = CurrentProject.Path & "\Dir(strPath & "*.xl*")"

Set xlsBook = Workbooks.Open(VarArquivo, , True)
Set xlsApp = xlsBook.Parent
Set xls = xlsApp.Sheets("BP")

xlsApp.visible = True
xlsBook.Application.Cells(1, 16; 200,16).Value = "Esta é a coluna p1"

Obrigado!

Veja estes dois código

'By JPaulo Maximo Access
Dim rst As DAO.Recordset, strSQL As String, strLivro As String, xls As Object
Set xls = CreateObject("Excel.Application")
strLivro = CurrentProject.Path & "\Análise Cancelamento.xlsm" 'pasta com o projeto
xls.Workbooks.Open (strLivro)
xls.visible = True
xls.Worksheets("Teste").Activate ' Nome da planilha
' strSQL = "SELECT * FROM PesoMedio;" 'consulta
strSQL = "SELECT tblExportar.PesoMedio FROM tblExportar;" 'criando a consulta
Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
xls.ActiveSheet.Range("J7").Select ' em que coluna e a partir de qual celula
xls.ActiveCell.CopyFromRecordset rst
xls.ActiveWorkbook.Save
'xls.Application.Quit
Set xls = Nothing



este codigo ele limpa as celuas e adiciona novos dados
coloque este codigo em uma evento ao clicar de um botão para voce testar


'By JPaulo Maximo Access' scandinavo
Dim rst As DAO.Recordset, strSQL As String, strLivro As String, xls As Object
Set xls = CreateObject("Excel.Application")
strLivro = CurrentProject.Path & "\Análise Cancelamento.xlsm" 'Arquivo excell na mesma pasta do arquivo access (CurrentProject.Path)
'strLivro = "C:\BaseProg\Análise Cancelamento.xlsm" 'Caminho do arquivo excell
xls.Workbooks.Open (strLivro)
xls.visible = True
xls.Worksheets("Teste").Activate ' Nome da planilha
'Limpa as celulas ante de adicionar novos dados''''''''''''''''''''''''''''''''''''''''''''''''''
xls.Worksheets("Teste").Range("A2:A1000").Value = "" 'LIMPA VARIAS LINHAS defina ate numero de linha sera apagada
xls.Worksheets("Teste").Range("B2:B1000").Value = ""
xls.Worksheets("Teste").Range("C2:C1000").Value = ""
xls.Worksheets("Teste").Range("D2:D1000").Value = ""
xls.Worksheets("Teste").Range("E2:E1000").Value = ""
xls.Worksheets("Teste").Range("F2:F1000").Value = ""
xls.Worksheets("Teste").Range("G2:G1000").Value = ""
xls.Worksheets("Teste").Range("H2:H1000").Value = ""
'xls.Worksheets("Teste").Range("A12").Value = "" 'LIMPA UMA UNICA CELULA
'Agora adiciona novas informações''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
strSQL = "SELECT * FROM tblPesoMedio;" 'consulta
'strSQL = "SELECT tblExportar.PesoMedio FROM tblExportar;" 'criando a consulta
Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
xls.ActiveSheet.Range("A2").Select ' em que coluna e a partir de qual celula se tiver 5 colunas na tabela vai ser A B C D E nao precisa informar
xls.ActiveCell.CopyFromRecordset rst
xls.ActiveWorkbook.Save 'salva a planilha
'xls.Application.Quit
Set xls = Nothing

Bom dia,

Obrigado pela resposta, mas o código só cola a informação em uma planilha específica "CurrentProject.Path & "\Análise Cancelamento.xlsm". Teria como fazê-lo para várias planilhas?

Tentei adaptar o código mas está dando erro e acho que tem de ter um loop:

Dim rst As DAO.Recordset, strSQL As String, strLivro As String, xls As Object
Set xls = CreateObject("Excel.Application")
strLivro = CurrentProject.Path & "\Dir("*.xl*")" 'pasta com o projeto
xls.Workbooks.Open (strLivro)
xls.visible = True
xls.Worksheets("Teste").Activate ' Nome da planilha
' strSQL = "SELECT * FROM PesoMedio;" 'consulta
strSQL = "SELECT tblExportar.PesoMedio FROM tblExportar;" 'criando a consulta
Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
xls.ActiveSheet.Range("J7").Select ' em que coluna e a partir de qual celula
xls.ActiveCell.CopyFromRecordset rst
xls.ActiveWorkbook.Save
'xls.Application.Quit
Set xls = Nothing

Consegue me ajudar?
Desde de já obrigado pela resposta.

Bom dia @Scandinavo!

Tentei fazer outro ajuste no código que você disponibilizou, mas ainda está com erro.
Esse ele já consegue ir na pasta e ler os arquivos, mas ele o lê e não o identifica informando que não o encontrou, erro em tempo de execução 1004 "o arquivo não pode ser localizado".

Segue o código:

Dim rst As DAO.Recordset, strSQL As String, xls As Object
Dim strlivro$
Set xls = CreateObject("Excel.Application")
strlivro = Dir("E:\AGF\teste\", vbArchive) 'pasta com o projeto"
xls.Workbooks.Open (strlivro)
xls.Visible = True
xls.Worksheets("bp").Activate ' Nome da planilha
'strSQL = "SELECT * FROM PesoMedio;" 'consulta
strSQL = "SELECT tabela1.campo1 FROM tblExportar;" 'criando a consulta
Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
xls.ActiveSheet.Range("P1:P100").Select ' em que coluna e a partir de qual celula
xls.ActiveCell.CopyFromRecordset rst
xls.ActiveWorkbook.Save
'xls.Application.Quit
Set xls = Nothing
Do While Not strlivro = ""
strlivro = Dir

Loop

End Sub

Alguma dica?

confira esta linha
strlivro = Dir("E:\AGF\teste\", vbArchive) 'pasta

Boa noite,

Valeu @Scandinavo.
Encontrei um jeito de ele abrir o arquivo e deu certo. Porém, agora ele abre a planilha, salva a informação na célula P1 a P100 só da primeira planilha, mas não salva nas demais apesar de deixar as linhas delas selecionadas. Então ele salva a informação somente na primeira planilha, mas deixa as demais (nas células p1 até p100) selecionadas e não salva as informações.
Outro fato é que a informação que estou tentando salvar é uma fórmula que traz o nome do arquivo na célula (=CÉL("filename")), porém, ele salva a fórmula mas não executa o resultado. Ela só funciona quando se clica dentro da célula.

Teria como ajustar?

Dim rst As DAO.Recordset, strSQL As String, xls As Object
Dim strlivro$
Set xls = CreateObject("Excel.Application")
strlivro = CurrentProject.Path & "\" & Dir("E:\AGF\teste\" & "*.xl*") 'pasta com o projeto"
xls.Workbooks.Open (strlivro)
xls.Visible = True
xls.Worksheets("bp").Activate ' Nome da planilha
'strSQL = "SELECT * FROM PesoMedio;" 'consulta
strSQL = "SELECT tabela1.campo1 FROM tabela1;" 'criando a consulta
Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
xls.ActiveSheet.Range("P1:P100").Select ' em que coluna e a partir de qual celula
xls.ActiveCell.CopyFromRecordset rst
xls.ActiveWorkbook.Save
xls.Application.Quit
Set xls = Nothing
Do While Not strlivro = ""
strlivro = Dir

Loop

End Sub

Veja esta função salva em 4 planilhas
Agora para o caso da formula não funcionar ai eu não sei.


Function Exportar2() 'varias planilhas
Dim rst As DAO.Recordset, strSQL As String, strLivro As String, xls As Object
Set xls = CreateObject("Excel.Application")
'strLivro = CurrentProject.Path & "\An?lise Cancelamento.xlsm" 'Arquivo excell na mesma pasta do arquivo access (CurrentProject.Path)
strLivro = "G:\CS\MEC\Import\An?lise_Cancelamento.xlsm" 'Caminho do arquivo excell
xls.Workbooks.Open (strLivro)
xls.Visible = True
'1 planilha******************************
xls.Worksheets("Cobertura_Base").Activate
'Limpa as celulas ante de adicionar novos dados'''''''''''''''''
xls.Worksheets("Cobertura_Base").Range("A2:A10000").Value = "" 'LIMPA VARIAS LINHAS defina ate numero de linha sera apagada
xls.Worksheets("Cobertura_Base").Range("B2:B10000").Value = ""
xls.Worksheets("Cobertura_Base").Range("C2:C10000").Value = ""
'xls.Worksheets("Teste").Range("A12").Value = "" 'LIMPA UMA UNICA CELULA
'Agora adiciona novas informa??es''''''''''''''''''''''''''''''
strSQL = "SELECT * FROM Cobertura_Linha;" 'consulta
'strSQL = "SELECT tblExportar.PesoMedio FROM tblExportar;" 'criando a consulta
Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
xls.ActiveSheet.Range("A2").Select ' em que coluna e a partir de qual celula se tiver 5 colunas na tabela vai ser A B C D E nao precisa informar
xls.ActiveCell.CopyFromRecordset rst

'2 planilha ****************************
xls.Worksheets("SICS").Activate ' Nome da planilha
'Limpa as celulas ante de adicionar novos dados'''''''''''''
xls.Worksheets("SICS").Range("A2:A20000").Value = "" 'LIMPA VARIAS LINHAS defina ate numero de linha sera apagada
xls.Worksheets("SICS").Range("B2:B20000").Value = ""
xls.Worksheets("SICS").Range("C2:C20000").Value = ""
'Agora adiciona novas informa??es'''''''''''''''''''''''''
strSQL = "SELECT * FROM Faturamento Geral;" 'consulta
Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
xls.ActiveSheet.Range("A2").Select ' em que coluna e a partir de qual celula se tiver 5 colunas na tabela vai ser A B C D E nao precisa informar
xls.ActiveCell.CopyFromRecordset rst

'3 planilha*****************************
xls.Worksheets("Libera??o").Activate ' Nome da planilha
'Limpa as celulas ante de adicionar novos dados''''''''''
xls.Worksheets("Libera??o").Range("A2:BS10000").Value = "" 'LIMPA VARIAS LINHAS defina ate numero de linha sera apagada
'Agora adiciona novas informa??es'''''''''''''''''''''''
strSQL = "SELECT * FROM Consulta_Liberacao;" 'consulta
Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
xls.ActiveSheet.Range("A2").Select ' em que coluna e a partir de qual celula se tiver 5 colunas na tabela vai ser A B C D E nao precisa informar
xls.ActiveCell.CopyFromRecordset rst
'xls.ActiveWorkbook.Save 'salva a planilha

'4 planilha*****************************
xls.Worksheets("A?ao_Dia").Activate ' Nome da planilha
'Limpa as celulas ante de adicionar novos dados''''''''''''''''''''''''''''''''''''''''''''''''''
xls.Worksheets("A?ao_Dia").Range("A2:A10000").Value = "" 'LIMPA VARIAS LINHAS defina ate numero de linha sera apagada
xls.Worksheets("A?ao_Dia").Range("B2:B10000").Value = ""
xls.Worksheets("A?ao_Dia").Range("C2:C10000").Value = ""
xls.Worksheets("A?ao_Dia").Range("D2:D10000").Value = ""
xls.Worksheets("A?ao_Dia").Range("E2:E10000").Value = ""
'Agora adiciona novas informa??es''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
strSQL = "SELECT * FROM registro;" 'consulta
Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
xls.ActiveSheet.Range("A2").Select ' em que coluna e a partir de qual celula se tiver 5 colunas na tabela vai ser A B C D E nao precisa informar
xls.ActiveCell.CopyFromRecordset rst
xls.ActiveWorkbook.Save 'salva a planilha
'xls.Application.Quit
Set xls = Nothing

End Function

Boa tarde e obrigado pela resposta,

Ele funciona muito bem, mas somente para UM arquivo com 4 abas (strLivro = "G:\CS\MEC\Import\An?lise_Cancelamento.xlsm").
Eu tenho 6000 arquivos xls com várias abas. Posso utilizar parte deste código para as abas, mas não estou conseguindo fazer o loop para os 6000 arquivos.

O código que eu postei anteriormente ele já consegue encontrar o próximo arquivo, mas não salva a informação nas linhas, apesar de deixa-las selecionadas, e no primeiro arquivo, que ele consegue gravar as informações, ele não executa a função que estou salvando nas linhas.

Então tenho dois problemas para resolver:
1 - O loop para salvar nos demais arquivos; e
2 - Ativar a fórmula que está sendo salva nas linhas.

Acho que tenho de acrescentar algo assim para ativar:
ActiveWindow.DisplayFormulas = True
ActiveWindow.DisplayFormulas = False

...mas, não estou conseguindo.

Att
RICARDO

Não tenho muito conhecimento nesta parte mas vamos tentar.

Para facilitar poste um exemplo e alguns arquivos excell.

Bom dia,

Disponibilizei os arquivos conforme solicitado (as planilhas e o BD).

Para o clique do botão funcionar, tanto o BD quanto os arquivos xls têm de está na mesma pasta.

Perceba que o sistema salva as informações apenas em uma delas e nas duas abas (BP e DRE) conforme necessito, mas não consegue realizar o loop (estou com algum problema no enlace).

'enlace para o loop.
Do While Len(strLivro) > 0
strLivro = Dir
Loop

Outro fato é que ele salva a fórmula na célula mas não a executa, ou seja, não traz o nome do arquivo que é o que estou precisando (então fica salvo em formato de fórmula).

att
RICARDO

Ola

esse comado dir só esta trazendo um arquivo.

Tentei fazer alguma coisa mas não consegui.

Uma opção acho que plausível (mas também ainda não consegui fazer)


Importar todos os arquivos excell para uma tabela com o caminho completo e depois construir um recordset para percorrer estes arquivos executando o código para inserir dados.

Seguindo o raciocínio anterior.

Veja:

Dim db As Database
Set db = CurrentDb()


Dim rst As dao.Recordset, strSQL As String, strLivro$, xls As Object

Dim rsA As dao.Recordset 'Variavel rsA vai pegar os arquivos

Set rsA = db.OpenRecordset("tblArquivos")
Do While Not rsA.EOF 'Repetirei At? que n?o haja mais arquivos
Set xls = CreateObject("Excel.Application")

strLivro = rsA!NomeArquivo ' este funciona
xls.Workbooks.Open (strLivro)
xls.Visible = True
'1 planilha******************************
xls.Worksheets("bp").Activate
'Limpa as celulas ante de adicionar novos dados'''''''''''''''''
xls.Worksheets("bp").Range("q1:q100").Value = "" 'LIMPA VARIAS LINHAS defina ate numero de linha sera apagada

'Agora adiciona novas informa??es''''''''''''''''''''''''''''''
strSQL = "SELECT * FROM tblArquivos;" 'consulta
Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
xls.ActiveSheet.Range("q1:q100").Select ' em que coluna e a partir de qual celula se tiver 5 colunas na tabela vai ser A B C D E nao precisa informar
xls.ActiveCell.CopyFromRecordset rst

'2 planilha ****************************
xls.Worksheets("dre").Activate ' Nome da planilha
'Limpa as celulas ante de adicionar novos dados'''''''''''''
xls.Worksheets("dre").Range("q1:q100").Value = "" 'LIMPA VARIAS LINHAS defina ate numero de linha sera apagada

'Agora adiciona novas informa??es'''''''''''''''''''''''''
strSQL = "SELECT * FROM tblArquivos;" 'consulta
Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
xls.ActiveSheet.Range("q1:q100").Select ' em que coluna e a partir de qual celula se tiver 5 colunas na tabela vai ser A B C D E nao precisa informar
xls.ActiveCell.CopyFromRecordset rst


xls.ActiveWorkbook.Save 'salva a planilha
xls.Application.Quit

rsA.MoveNext 'Movo para proximo registro
Loop

Set xls = Nothing
'Fecha as Conexoes abertas
Set db = Nothing
Set rsA = Nothing

Boa noite,

O código deu o seguinte erro: "erro em tempo de execução 3265". Item não encontrado nesta coleção.
A linha do erro é a: strLivro = rsA!NomeArquivo

É como se ele não tivesse encontrado a pasta onde os arquivos estão.

Boa noite,

Perdoe-me. Agora que entendi seu código. Na verdade ele pega os arquivos que estão na lista da tabela com os respectivos nomes e endereços.
Então tenho de criar essa lista. É isso?

"Então tenho de criar essa lista. É isso?"

No frmFormulario inseri um botão "importar" que utiliza um código feito por Jpaulo ele já faz isto, veja ai tem mais um modulo inserido com a função.

Boa noite.

Funcionou perfeitamente. obrigado!
Agora estou tentando fazer a segunda parte que é importar todos os registros da aba específica para uma única tabela.
Consegui esse código abaixo e o ajustei. Ele funciona, mas está reportando tela de erro quando exclui campo incompatível.
Teria como eliminar esses avisos de erros?

Dim strPathFile As String, strFile As String, strPath As String
Dim strTable As String
Dim blnHasFieldNames As Boolean
blnHasFieldNames = True

strPath = "E:\AGF\teste\tes\" ' drive onde se situa o seu documento excel
strTable = "Tab_exemplo" 'nome da tabela no seu banco
strFile = Dir(strPath & "*.xl*") 'nome do seu excel, se mudar para "*.xls" importa todas as folhas excel que estiverem em C:\ para a _ tabela do banco.

Do While Len(strFile) > 0
strPathFile = strPath & strFile

DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, strTable, strPathFile, blnHasFieldNames, "plan1" & "!A1:j100"

strFile = Dir()
Loop

End Sub

Já tentou por no inicio do código


On Error Resume Next


se não der certo poste um exemplo