Notifications
Clear all

Macro ou VBA para copiar a Planilha para outra Pasta de Trabalho

Página 2 / 2

marmen
(@marmen)
Eminent Member Registered
Entrou: 4 anos atrás
Posts: 32
Topic starter  

Olá, tudo bem com vocês??

Eu tenho um modelo de formulário mensal. Eu preciso que, ao final de cada mês, eu consiga, através de uma macro ou cód VBA copiar esse formulário para uma nova pasta de trabalho. E caso eu tente fazer isso de novo apareça uma mensagem falando que já foi copiada. Para não salvar duplicidades.

- Segue a planilha de Exemplo.

Fico no aguardo de uma resposta!!

Obrigado.

Att' Marcio Mendes


ResponderCitar (Quote)
Tags do Tópico
marmen
(@marmen)
Eminent Member Registered
Entrou: 4 anos atrás
Posts: 32
Topic starter  

@teleguiado continua salvando em 3 planilhas separadas. A questão de não aparecer o botão foi resolvido.

 

Att' Marcio Mendes


ResponderCitar (Quote)
teleguiado
(@teleguiado)
Estimable Member Registered
Entrou: 5 anos atrás
Posts: 118
 

@marmen

Acho que agora foi.

 

Obrigado.

Teleguiado.
E-mail: telegui4do@gmail.com


ResponderCitar (Quote)
marmen
(@marmen)
Eminent Member Registered
Entrou: 4 anos atrás
Posts: 32
Topic starter  

@teleguiado agora foi. Obrigado!

 

Att' Marcio Mendes


ResponderCitar (Quote)
marmen
(@marmen)
Eminent Member Registered
Entrou: 4 anos atrás
Posts: 32
Topic starter  

@teleguiado Consegue fazer 2 alterações nesse código, por gentileza! 
Primeiro: Gostaria que o cód. copiasse somente os valores, pois algumas células da guia tem referência com outra guia 

Segundo: Minha planilha está protegida por senha e quando eu uso esse código ela volta sem proteção. Pra tentar resolver fiz dessa forma mais não deu certo.

Option Explicit
Public fname, NomeArquivo As Variant

Sub Salvarformulario()

Sheets("Teste").Unprotect "senha"
ThisWorkbook.Activate

Dim msg, style, Title, Response, mystring
Dim UserName As String
Dim lpBuff As String * 25
NomeArquivo = Application.ThisWorkbook.Name
Application.ScreenUpdating = False

'
' Salvar a planilha em uma nova pasta de trabalho
'
msg = "Deseja salvar a Nota em um arquivo novo?"
style = vbYesNo + vbQuestion + vbDefaultButton2
Title = "Salvar Formulário"
Response = MsgBox(msg, style, Title)
If Response = vbYes Then

'
' Abre uma nova pasta de trabalho
'

Workbooks.Add
Do
fname = InputBox("Qual o nome do Arquivo?")
Loop Until fname <> False
'
' Salva a nova pasta de trabalho com o nome desejado
'
Application.Dialogs(xlDialogSaveAs).Show Arg1:=fname, Arg2:=xlOpenXMLWorkbook

'
' Copia a pagina Aprovall e salva por fname
'
Windows(NomeArquivo).Activate
Range("A5:G200").Select
Selection.Copy

' Sheets("Formulário").Copy Before:=Workbooks(Fname & ".xlsx").Sheets(1)

Windows(fname & ".xlsx").Activate
Range("A1:G200").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Range("a1").Select
Application.DisplayAlerts = False
ThisWorkbook.Save
End If
Application.ScreenUpdating = True

Sheets("Teste").Protect "senha"
ThisWorkbook.Activate

End Sub

 

-----Grato!

Att' Marcio Mendes


ResponderCitar (Quote)
teleguiado
(@teleguiado)
Estimable Member Registered
Entrou: 5 anos atrás
Posts: 118
 

@marmen

Veja se deu certo.

 

Option Explicit
Public fname, NomeArquivo As Variant

Sub Salvarformulario()

Sheets("Teste").Unprotect Password:="senha"
ThisWorkbook.Activate

Dim msg, style, Title, Response, mystring
Dim UserName As String
Dim lpBuff As String * 25
NomeArquivo = Application.ThisWorkbook.Name
Application.ScreenUpdating = False

'
' Salvar a planilha em uma nova pasta de trabalho
'
msg = "Deseja salvar a Nota em um arquivo novo?"
style = vbYesNo + vbQuestion + vbDefaultButton2
Title = "Salvar Formulário"
Response = MsgBox(msg, style, Title)
If Response = vbYes Then

'
' Abre uma nova pasta de trabalho
'

Workbooks.Add
Do
fname = InputBox("Qual o nome do Arquivo?")
Loop Until fname <> False
'
' Salva a nova pasta de trabalho com o nome desejado
'
Application.Dialogs(xlDialogSaveAs).Show Arg1:=fname, Arg2:=xlOpenXMLWorkbook

'
' Copia a planilha e salva na nova pasta de trabalho criada
'
Windows(NomeArquivo).Activate
Range("A5:G200").Select
Selection.Copy

' Sheets("Formulário").Copy Before:=Workbooks(Fname & ".xlsx").Sheets(1)

Windows(fname & ".xlsx").Activate
Range("A1:G200").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Application.CutCopyMode = False
Range("a1").Select
Application.DisplayAlerts = False
ThisWorkbook.Save
End If
Application.ScreenUpdating = True

Windows(NomeArquivo).Activate
Sheets("Teste").Protect Password:="senha"

End Sub

Obrigado.

Teleguiado.
E-mail: telegui4do@gmail.com


ResponderCitar (Quote)
marmen
(@marmen)
Eminent Member Registered
Entrou: 4 anos atrás
Posts: 32
Topic starter  

@teleguiado Segue o erro que apareceu no final ao executar o código. E a planilha não ficou protegida após eu ter usado o código.

 

Att' Marcio Mendes


ResponderCitar (Quote)
teleguiado
(@teleguiado)
Estimable Member Registered
Entrou: 5 anos atrás
Posts: 118
 

@marmen

Células mescladas.

Obrigado.

Teleguiado.
E-mail: telegui4do@gmail.com


ResponderCitar (Quote)
teleguiado
(@teleguiado)
Estimable Member Registered
Entrou: 5 anos atrás
Posts: 118
 

@marmen

Teste desse jeito.

Option Explicit
Public fname, NomeArquivo As Variant

Sub Salvarformulario()

Sheets("Teste").Unprotect Password:="senha"
ThisWorkbook.Activate

Dim msg, style, Title, Response, mystring
Dim UserName As String
Dim lpBuff As String * 25
NomeArquivo = Application.ThisWorkbook.Name
Application.ScreenUpdating = False

'
' Salvar a planilha em uma nova pasta de trabalho
'
msg = "Deseja salvar a Nota em um arquivo novo?"
style = vbYesNo + vbQuestion + vbDefaultButton2
Title = "Salvar Formulário"
Response = MsgBox(msg, style, Title)
If Response = vbYes Then

'
' Abre uma nova pasta de trabalho
'

Workbooks.Add
Do
fname = InputBox("Qual o nome do Arquivo?")
Loop Until fname <> False
'
' Salva a nova pasta de trabalho com o nome desejado
'
Application.Dialogs(xlDialogSaveAs).Show Arg1:=fname, Arg2:=xlOpenXMLWorkbook

'
' Copia a planilha e salva na nova pasta de trabalho criada
'
Windows(NomeArquivo).Activate
Range("A5:G200").Select
Selection.Copy

' Sheets("Formulário").Copy Before:=Workbooks(Fname & ".xlsx").Sheets(1)

Windows(fname & ".xlsx").Activate
Range("A1:G200").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False


Application.CutCopyMode = False
Range("a1").Select
Application.DisplayAlerts = False
ThisWorkbook.Save
End If
Application.ScreenUpdating = True

Windows(NomeArquivo).Activate
Sheets("Teste").Protect Password:="senha"

End Sub

Obrigado.

Teleguiado.
E-mail: telegui4do@gmail.com


ResponderCitar (Quote)
marmen
(@marmen)
Eminent Member Registered
Entrou: 4 anos atrás
Posts: 32
Topic starter  

@teleguiado Deu certo, obrigado!

Uma ultima dúvida para fecharmos esse tópico com chave de ouro rsrs

Criei um código através de uma macro...como já disse não entendo muito de VBA 😆 

atribui um botão a essa macro com a função de excluir as informações de um conjunto de células. Eu queria que antes dessa exclusão ser feita aparecesse uma msgbox perguntando se quero realmente excluir aquele intervalo.

Segue o código:

Sub excluirLançamentos()
'
' excluirLançamentos Macro
'
ActiveWindow.SmallScroll Down:=-15
Range("C10:G10").Select

Sheets("teste").Unprotect "senha"

Range(Selection, Selection.End(xlDown)).Select

Selection.ClearContents

Sheets("teste").Protect "senha"

Range("C10").Select

End Sub

Att' Marcio Mendes


ResponderCitar (Quote)
teleguiado
(@teleguiado)
Estimable Member Registered
Entrou: 5 anos atrás
Posts: 118
 

@marmen no código anterior tem o que você precisa.

 

Sub excluirLançamentos()
Dim msg, style, Title, Response, mystring
'
' excluirLançamentos Macro
'
msg = "Deseja Excluir Lançamentos?"
style = vbYesNo + vbQuestion + vbDefaultButton2
Title = "Excluir Lançamento"
Response = MsgBox(msg, style, Title)
If Response = vbYes Then
ActiveWindow.SmallScroll Down:=-15
Range("C10:G10").Select

Sheets("teste").Unprotect "senha"

Range(Selection, Selection.End(xlDown)).Select

Selection.ClearContents

Sheets("teste").Protect "senha"

Range("C10").Select
End If
End Sub

Obrigado.

Teleguiado.
E-mail: telegui4do@gmail.com


ResponderCitar (Quote)
marmen
(@marmen)
Eminent Member Registered
Entrou: 4 anos atrás
Posts: 32
Topic starter  

@teleguiado BOA TARDE

o código para salvar a planilha está funcionando perfeitamente!!

Só que tem um porém, preciso que o código funcione para o excel em um MacBook. Não sei se seria possível...

Att' Marcio Mendes


ResponderCitar (Quote)
teleguiado
(@teleguiado)
Estimable Member Registered
Entrou: 5 anos atrás
Posts: 118
 

@marmen

Talvez seja porque tem diferença da versão para o windows da versão pra macbook. Veja no link abaixo as funções que tem no windows e não tem no mac e veja se não esta usando alguma função que não é compativel com o mac.

 

Link

Obrigado.

Teleguiado.
E-mail: telegui4do@gmail.com


ResponderCitar (Quote)
marmen
(@marmen)
Eminent Member Registered
Entrou: 4 anos atrás
Posts: 32
Topic starter  

@teleguiado Todos os outros recursos funcionaram. Será que não é porque esse código usa a janela de salvamento do windows. Não teria um código diferente para o sistema operacional do Mac?

Att' Marcio Mendes


ResponderCitar (Quote)
teleguiado
(@teleguiado)
Estimable Member Registered
Entrou: 5 anos atrás
Posts: 118
 

@marmen

Veja se nesse link não resolve seu problema.

 

Obrigado.

Teleguiado.
E-mail: telegui4do@gmail.com


ResponderCitar (Quote)
Página 2 / 2