Notifications
Clear all

Criar sequencia de arquivos

8 Posts
2 Usuários
0 Reactions
1,403 Visualizações
fcarlosc
(@fcarlosc)
Posts: 453
Honorable Member
Topic starter
 

Bom-dia !

Gostaria de uma maneira de criar uma sequencia de arquivos .xls e/ou .xlsm à partir de um arquivo (Matriz).
Eu iria digitar a sequencia nos textboxes (Inicio e Fim)

Ex.: Inicio = 1
Fim = 10

Aí seria criado a sequencia: 1.xls, 2.xls, 3.xls,... e assim até o "Fim", esses arquivos seriam criados na pasta "corrente".

Att,

Francisco

 
Postado : 17/12/2017 8:12 am
(@klarc28)
Posts: 971
Prominent Member
 
Private Sub cmd_Salvar1_Click()
    Call CriaArquivo(Sheets("Setor Alfa"), ThisWorkbook.Path)
End Sub

Private Sub cmd_Salvar2_Click()
    Call CriaArquivo(Sheets("Setor Beta"), ThisWorkbook.Path)
End Sub

Private Sub cmd_Salvar3_Click()
    Call CriaArquivo(Sheets("Setor Gamma"), ThisWorkbook.Path)
End Sub


Sub CriaArquivo(mPlan As Worksheet, mPathSave As String)
Dim NovoArquivoXLS As Workbook
Dim sht As Worksheet

    'Cria um novo arquivo excel
    Set NovoArquivoXLS = Application.Workbooks.Add

    'Copia a planilha para o novo arquivo criado
    mPlan.Copy Before:=NovoArquivoXLS.Sheets(1)

    'Salva o arquivo
    NovoArquivoXLS.SaveAs mPathSave & "" & mPlan.Name & ".xls"

    MsgBox "Novo arquivo salvo em: " & mPathSave & "" & mPlan.Name & ".xls", vbInformation

End Sub
Option Explicit

Private Sub CommandButton1_Click()
Dim i, inicio, fim As Integer

On Error GoTo final
inicio = CInt(txtInicio.Text)
fim = CInt(txtFim.Text)

For i = inicio To fim

Call CriaArquivo(i, ThisWorkbook.Path)

Next i

final:

End Sub

Sub CriaArquivo(ByVal numero As Integer, ByVal mPathSave As String)
Dim NovoArquivoXLS As Workbook
Dim sht As Worksheet
On Error GoTo final
    'Cria um novo arquivo excel
    Set NovoArquivoXLS = Application.Workbooks.Add

    'Copia a planilha para o novo arquivo criado
    'mPlan.Copy Before:=NovoArquivoXLS.Sheets(1)

    'Salva o arquivo
    NovoArquivoXLS.SaveAs mPathSave & "" & numero & ".xls"

   ' MsgBox "Novo arquivo salvo em: " & mPathSave & "" & mPlan.Name & ".xls", vbInformation
final:

End Sub

Se o código resolve, favor marcar o tópico como resolvido.
Se não resolve, favor dizer o que falta.

 
Postado : 17/12/2017 8:31 am
fcarlosc
(@fcarlosc)
Posts: 453
Honorable Member
Topic starter
 

klarc28, seria exatamente isso, porém não teria como definir um arquivo (Matriz), não precisa que abra a caixa de diálogo para procurar o arquivo (Matriz) já seria definido o caminho (corrente) na pasta em que em que se encontra o arquivo principal --> (Criar Arquivos - Excel). E pegar esse arquivo (Matriz) e copiar o conteúdo dele e colar nos arquivos que estão sendo criados.

Att,

Francisco

 
Postado : 17/12/2017 9:46 am
(@klarc28)
Posts: 971
Prominent Member
 

Quando você se comunica por texto, é importante colocar ponto de interrogação quando é uma pergunta, caso contrário, vira uma afirmação:

"klarc28, seria exatamente isso, porém não teria como definir um arquivo (Matriz)"

Seria o mesmo arquivo com nomes diferentes? Salvar como?

Option Explicit

Private Sub CommandButton1_Click()
Dim i, inicio, fim As Integer

On Error GoTo final
inicio = CInt(txtInicio.Text)
fim = CInt(txtFim.Text)

For i = inicio To fim

Call CriaArquivo2(ThisWorkbook, i, ThisWorkbook.Path)

Next i

final:

End Sub

Sub CriaArquivo(ByVal numero As Integer, ByVal mPathSave As String)
Dim NovoArquivoXLS As Workbook
Dim sht As Worksheet
On Error GoTo final
    'Cria um novo arquivo excel
    Set NovoArquivoXLS = Application.Workbooks.Add

    'Copia a planilha para o novo arquivo criado
    'mPlan.Copy Before:=NovoArquivoXLS.Sheets(1)

    'Salva o arquivo
    NovoArquivoXLS.SaveAs mPathSave & "" & numero & ".xls"

   ' MsgBox "Novo arquivo salvo em: " & mPathSave & "" & mPlan.Name & ".xls", vbInformation
final:

End Sub

Sub CriaArquivo2(ByRef wb As Workbook, ByVal numero As Integer, ByVal mPathSave As String)
Dim NovoArquivoXLS As Workbook
Dim sht As Worksheet



On Error GoTo final
    'Cria um novo arquivo excel
    Set NovoArquivoXLS = wb
    'Copia a planilha para o novo arquivo criado
    'mPlan.Copy Before:=NovoArquivoXLS.Sheets(1)

    'Salva o arquivo
    NovoArquivoXLS.SaveAs mPathSave & "" & numero & ".xls"

   ' MsgBox "Novo arquivo salvo em: " & mPathSave & "" & mPlan.Name & ".xls", vbInformation
final:

End Sub


 

 
Postado : 17/12/2017 9:58 am
(@klarc28)
Posts: 971
Prominent Member
 

Se o código resolve, favor marcar o tópico como resolvido.
Se não resolve, favor dizer o que falta.

 
Postado : 17/12/2017 11:18 am
fcarlosc
(@fcarlosc)
Posts: 453
Honorable Member
Topic starter
 

Está 99%...só preciso que seja definido o local do arquivo (Matriz)..."Matriz.xls ou Matriz.xlsm" e desse arquivo criar os demais (da sequencia dos text´s) e não o arquivo (corrente) no caso o arquivo que estou utilizando o (Criar Arquivos - Excel).

Porque...!? Por que eu vou abrir o meu "Sistema" vou executar esse "Criar Arquivos" e depois, ainda no "Sistema" vou abrir outro "Form" para buscar o arquivo criado.
Ex.: se eu criei a sequencia de 5000 à 5010 (.xls / .xlsm) quando eu abrir o "Form", no textbox vou digitar 5009 e ele vai buscar o arquivo que já irá abrir um outro formulário para poder digitar as informações.

O "Matriz" no caso, já tem as abas que preciso.

bom...a idéia é essa !!!
e se for possível.

Att,

Francisco

 
Postado : 17/12/2017 12:03 pm
(@klarc28)
Posts: 971
Prominent Member
 
Option Explicit

Private Sub CommandButton1_Click()
Dim i, inicio, fim As Integer

On Error GoTo final
inicio = CInt(txtInicio.Text)
fim = CInt(txtFim.Text)

For i = inicio To fim

Call CriaArquivo3("C:Pasta1Matriz.xls", i, "C:Pasta2")

Next i

final:

End Sub

Sub CriaArquivo(ByVal numero As Integer, ByVal mPathSave As String)
Dim NovoArquivoXLS As Workbook
Dim sht As Worksheet
On Error GoTo final
    'Cria um novo arquivo excel
    Set NovoArquivoXLS = Application.Workbooks.Add

    'Copia a planilha para o novo arquivo criado
    'mPlan.Copy Before:=NovoArquivoXLS.Sheets(1)

    'Salva o arquivo
    NovoArquivoXLS.SaveAs mPathSave & "" & numero & ".xls"

   ' MsgBox "Novo arquivo salvo em: " & mPathSave & "" & mPlan.Name & ".xls", vbInformation
final:

End Sub

Sub CriaArquivo2(ByRef wb As Workbook, ByVal numero As Integer, ByVal mPathSave As String)
Dim NovoArquivoXLS As Workbook
Dim sht As Worksheet



On Error GoTo final
    'Cria um novo arquivo excel
    Set NovoArquivoXLS = wb
    'Copia a planilha para o novo arquivo criado
    'mPlan.Copy Before:=NovoArquivoXLS.Sheets(1)

    'Salva o arquivo
    NovoArquivoXLS.SaveAs mPathSave & "" & numero & ".xls"

   ' MsgBox "Novo arquivo salvo em: " & mPathSave & "" & mPlan.Name & ".xls", vbInformation
final:

End Sub

Sub CriaArquivo3(ByVal caminhoOrigem As String, ByVal numero As Integer, ByVal caminhoDestino As String)
Dim NovoArquivoXLS As Workbook
Dim sht As Worksheet

Workbooks.Open (caminhoOrigem)

On Error GoTo final
    'Cria um novo arquivo excel
    Set NovoArquivoXLS = ActiveWorkbook
    'Copia a planilha para o novo arquivo criado
    'mPlan.Copy Before:=NovoArquivoXLS.Sheets(1)

    'Salva o arquivo
    NovoArquivoXLS.SaveAs caminhoDestino & "" & numero & ".xls"
Workbooks(caminhoOrigem).Close SaveChanges:=True
   ' MsgBox "Novo arquivo salvo em: " & caminhoDestino & "" & mPlan.Name & ".xls", vbInformation
final:

End Sub



 
Postado : 17/12/2017 12:56 pm
fcarlosc
(@fcarlosc)
Posts: 453
Honorable Member
Topic starter
 

É isso mesmo...vlw...!

 
Postado : 17/12/2017 2:22 pm