Macro vba exportar arquivo excel - resolvido

Marcus Nagel_758472 · 24 de fevereiro de 2016

[RESOLVIDO!!!!]

Boa noite pessoal.

Preciso de uma ajudinha para ajustar uma macro. Hoje ela separa as informações por fornecedor e cria um arquivo dentro de uma pasta no C: para cada fornecedor.

Tenho uma planilha com algumas informações entre elas Fornecedor Agrupado.

Em outra aba tenho essa mesma coluna Fornecedor Agrupado e a coluna Site Sharepoint, onde contem o caminho que quero exportar o arquivo de cada fornecedor. Cada fornecedor possui um caminho diferente.

Tenho os dois códigos a seguir:

Sub a02EnviarEmails()

Dim Folder As String, Recipient As String, Recipient2 As String
Dim FSO As Object
Dim db As DAO.Database
Dim rs As DAO.Recordset, rs2 As DAO.Recordset
Dim c As Long


Application.DisplayAlerts = False

Folder = "C:\Users\marcur09\Desktop\A\"

Set FSO = CreateObject("Scripting.FileSystemObject")
Set db = OpenDatabase(ThisWorkbook.FullName, False, True, "Excel 8.0;HDR=Yes;")
Set rs = db.OpenRecordset("SELECT DISTINCT [Fornecedor Agrupado] FROM [Plan1$]")


For Each File In FSO.GetFolder(Folder).Files
    Kill File
Next

While Not rs.EOF
    Set rs2 = db.OpenRecordset("SELECT * FROM [Plan1$] WHERE [Fornecedor Agrupado]='" & rs(0) & "'")
    Workbooks.Add
        For c = 0 To rs2.Fields.Count - 1
            Cells(1, c + 1) = rs2.Fields(c).Name
        Next
    Range("A2").CopyFromRecordset rs2
    Range("A:A").TextToColumns
    Range("A:A").NumberFormat = "dd/mm/yyyy"
    Range("P:P").NumberFormat = "dd/mm/yyyy"
    Range("A:AZ").EntireColumn.AutoFit
    ActiveWorkbook.Close True, Folder & Format(Date, "dd-mm-yyyy") & " " & rs(0)
        rs.MoveNext
Wend

End Sub

Sub tst()

Const sSource As String = "C:\Users\marcur09\Desktop\A\3M.xlsx" 'change to suit

With CreateObject("WScript.Network")

.MapNetworkDrive "T:", "\\team.braskem.com.br\sites\gpss\mro\Produtividade\_Marcus\teste\3M" 'change to suit
If Len(Dir(sSource)) Then CreateObject("Scripting.FileSystemObject").copyfile sSource, "T:\"
Application.Wait Now + TimeSerial(0, 0, 3)

On Error Resume Next
.RemoveNetworkDrive "T:"
On Error GoTo 0

End With

End Sub

Conseguem me ajudar???

OBRIGADO!!!

Teste 1 Macro Export To SharePoint .xlsm

CasaDoHardware · 24 de fevereiro de 2016

Daria pra ajudar se você soubessemos o que você precisa, afinal você disse que tem o codigo e que precisa de ajuda, mas nao disse qual.

Marcus Nagel_758472 · 24 de fevereiro de 2016

@CasaDoHardware Desculpe, escrevi meio apressado.

A primeira macro (a02EnviarEmails) divide o arquivo por fornecedor, cria um arquivo diferente para cada um desses fornecedores e coloca a data que foi executada. Ex: 23-02-2016 3M.xlsx

Preciso de uma macro que pegue esses arquivos que estão numa pasta no drive C e export para o sharepoint indicado na aba "banco_dados", coluna "Site Sharepoint".

Por exemplo:

o arquivo 3M tem que ser exportado para a pasta "https://sharepoint/mysite/3M".

o arquvio Abecom para "https://sharepoint/mysite/Abecom".

e por ai vai.....

A segunda macro (tst) exporta o arquivo para o local certo, porém preciso copiar e colar varias vezes, pois ela serve apenas para um fornecedor. E devido a data que a macro "a02EnviarEmails" coloca no nome do arquivo, teria que entrar e mudar todas as vezes que for utilizar.

Acho que agora deu para explicar.

CasaDoHardware · 24 de fevereiro de 2016

Nao entendi o que você altera no codigo manualmente para funcionar...

Mas da seja la o que for e so fazer um for para que essa alteração aconteça pelo codigo uma sugestão seria criar uma lista que pode ser apagada cada vez que o codigo rodar, para usar no for de inserção.

Posso tentar fazer o For mas nao entendi onde deve ser alterado para funcionar como você precisa.

Marcus Nagel_758472 · 24 de fevereiro de 2016

@CasaDoHardware

Sub tst()

Const sSource As String = "C:\Users\marcur09\Desktop\A\3M.xlsx" 'change to suit

With CreateObject("WScript.Network")

Essa parte "Const sSource ........... \Desktop\A\3M.xlsx."

A parte em negrito eu teria que mudar manualmente, pois ela é o arquivo que desejo exportar. O problema é que quando rodo a primeira macro, ela salva o arquivo como (exemplo) 24-02-2016 3M.xlsx e o nome deve ser exatamente o mesmo para a segunda macro funcionar.

Precisava de algo que faça com que na primeira macro ele salve o arquivo e já exporte para o sharepoint, sem ser necessário a segunda macro.

Macro:

Separar Fornecedor -> Salvar um arquivo para cada fornecedor -> exportar cada fornecedor para sua pasta no sharepoint ( de acordo com a coluna "Site Sharepoint" da aba "banco_dados" do arquivo inicial)

Se ficar mais fácil, a primeira macro pode ser alterada.

CasaDoHardware · 25 de fevereiro de 2016

Uma coisa que vi no seu arquivo é que você tem uma lista com os caminhos e uma macro para cada planilha gerada???

E só estes tres???

Se for só o problema de enviar todos os arquivo em um unico comando

pode usar esse

Sub Enviartudo()

'Se quiser enviar alguma macro antes dessas 3 é so inserir antes aqui

Call tst
Call tst2
Call tst3

End Sub

Marcus Nagel_758472 · 25 de fevereiro de 2016

@CasaDoHardware

Se o nome dos arquivos não fosse dinamico poderia usar essa sim.

Acontece que o nome do arquivo muda conforme o dia que for executado.

@CasaDoHardware

Sub a02EnviarEmails()

Dim Folder As String, Recipient As String, Recipient2 As String
Dim FSO As Object
Dim db As DAO.Database
Dim rs As DAO.Recordset, rs2 As DAO.Recordset
Dim c As Long


Application.DisplayAlerts = False

Folder = "C:\Users\marcur09\Desktop\A\"

Set FSO = CreateObject("Scripting.FileSystemObject")
Set db = OpenDatabase(ThisWorkbook.FullName, False, True, "Excel 8.0;HDR=Yes;")
Set rs = db.OpenRecordset("SELECT DISTINCT [Fornecedor Agrupado] FROM [Plan1$]")


For Each File In FSO.GetFolder(Folder).Files
    Kill File
Next

While Not rs.EOF
    Set rs2 = db.OpenRecordset("SELECT * FROM [Plan1$] WHERE [Fornecedor Agrupado]='" & rs(0) & "'")
    Workbooks.Add
        For c = 0 To rs2.Fields.Count - 1
            Cells(1, c + 1) = rs2.Fields(c).Name
        Next
    Range("A2").CopyFromRecordset rs2
    Range("A:A").TextToColumns
    Range("A:A").NumberFormat = "dd/mm/yyyy"
    Range("P:P").NumberFormat = "dd/mm/yyyy"
    Range("A:AZ").EntireColumn.AutoFit
    ActiveWorkbook.Close True, Folder & Format(Date, "dd-mm-yyyy") & " " & rs(0)
''''''''''''''''' Pegar esse arquivo salvo acima e exportar para o sharepoint''''''''''''''''''


        rs.MoveNext
Wend

End Sub

No código acima coloquei uma linha "Pegar esse arquivo salvo acima e exportar para o sharepoint", para dar uma ideia do que preciso.

CasaDoHardware · 25 de fevereiro de 2016

Declara uma variavel para o nome do arquivo

Dim arquivo as string

Arquivo = nome que quiser

No lugar do nome do arquivo use assim

No lugar disso

C:\Users\marcur09\Desktop\A\3M.xlsx

Use isso.

C:\Users\marcur09\Desktop\A\ & Arquivo & ".xlsx"

Marcus Nagel_758472 · 25 de fevereiro de 2016

@CasaDoHardware

Tem como

esse C:\Users\marcur09\Desktop\A\ & Arq & ".xlsx" mostrar a data atual e o nome do fornecedor? Se fizer isso já vai ser top!!!!

Exemplo: Fornecedor Abecom

C:\Users\marcur09\Desktop\A\Format(Date, "dd-mm-yyyy") & " " & Arq & ".xlsx"

Ai aparece:

C:\Users\marcur09\Desktop\A\24-02-2016 Abecom.xlsx

E outra pergunta. Como faço para exportar para o site mostrado na aba [base_dados]?

CasaDoHardware · 25 de fevereiro de 2016

Suponha que o nome do arquivo seja a celula A1

então fica assim

Dim Arquivo as string

Arquivo = Format(Date, "DD.MM.YYYY") & " - " & Range("A1").Value

E so usar a do modo que disse anteriormente

C:\Users\marcur09\Desktop\A\ & Arquivo & ".xlsx"

O arquivo vai ser salvo com a data e o nome que estiver em A1 (troque de acordo com sua necessidade.)

Marcus Nagel_758472 · 25 de fevereiro de 2016

@CasaDoHardware

Boa valeu!!

Vou testar amanhã! E aviso aqui se deu certo!

Obrigado!

Marcus Nagel_758472 · 26 de fevereiro de 2016

@CasaDoHardware

Com sua ajuda consegui fazer o que queria!

Usei apenas a primeira macro com algumas ideias de modificação que você deu!

MUITO OBRIGADO!!!

Segue o código para alguem se precisar.

Divide a planilha com base no Fornecedor e salva na pasta de cada Fornecedor no sharepoint.

Sub aExportParaSharepoint()

Dim Folder As String
Dim Caminho As String
Dim Fornecedor As String
Dim FSO As Object
Dim db As DAO.Database
Dim rs As DAO.Recordset, rs2 As DAO.Recordset
Dim c As Long


Application.DisplayAlerts = False

Set FSO = CreateObject("Scripting.FileSystemObject")
Set db = OpenDatabase(ThisWorkbook.FullName, False, True, "Excel 8.0;HDR=Yes;")
Set rs = db.OpenRecordset("SELECT DISTINCT [Fornecedor Agrupado] FROM [Plan1$]")
While Not rs.EOF
    Set rs2 = db.OpenRecordset("SELECT * FROM [Plan1$] WHERE [Fornecedor Agrupado]='" & rs(0) & "'")
    Workbooks.Add
        For c = 0 To rs2.Fields.Count - 1
            Cells(1, c + 1) = rs2.Fields(c).Name
        Next

Caminho = "\\mysite\sites\gpss\mro\teste\" 'troque pelo caminho da pasta do sharepoint
Fornecedor = rs(0) & "\" 'pega o fornecedor e complementa o Caminho

Let Folder = Caminho & Fornecedor 'Caminho completo

Range("A2").CopyFromRecordset rs2
    Range("A:A").TextToColumns
    Range("A:A").NumberFormat = "dd/mm/yyyy"
    Range("P:P").NumberFormat = "dd/mm/yyyy"
    Range("A:AZ").EntireColumn.AutoFit
    Range("A1:C1").Interior.Color = RGB(228, 31, 43)
    Range("a1:c1").Font.ColorIndex = 2
    Range("A1:C1").Font.Bold = True
    ActiveWorkbook.Close True, Folder & Format(Date, "dd-mm-yyyy") & " " & rs(0) 'salva na pasta com data e o nome do fornecedor

        rs.MoveNext
Wend

For Each File In FSO.GetFolder(Folder).Files
    Kill File
Next

End Sub