Notifications
Clear all

Ajuda Salvar arquivo com data + nº sequenci e resetar campos

8 Posts
2 Usuários
0 Reactions
2,180 Visualizações
(@felipesalomao)
Posts: 103
Estimable Member
Topic starter
 

Olá pessoal, hoje resolvi automatizar e aperfeiçoar uma planilha que usamos na empresa.

Estou com algumas pendências que não consegui Resolver.

1º - Na Guia Cadastro ao mudar o produto (Descrição), automaticamente a planilha cria uma nova linha nas guias Cadastro, Impostos e Estimativas Finais, todos dados são lidos de acordo com produto automaticamente usando muitas Procvs e condicionais. O que gostaria de aperfeiçoar é que essa inserção de linha automática só funciona corretamente se deixarmos selecionado a ultima célula dos produtos, no caso D26 na guia Cadastro, C17 na guia Impostos e Estimativas Finais, D17 na guia Order list, caso contrários a macro não funciona corretamente

2º - Ao apertar o botão Resetar Orçamento na guia Cadastro, gostaria que fosse apagado todas as linhas que foram adicionadas e voltar para o padrão de 5 linhas de produtos com os campos D22:D26 apagados

3º - Ao apertar o botão Pedido Aprovado na guia cadastro, gostaria que automaticamente a fosse salvo dois arquivos, o primeiro seria a planilha inteira com todas as guias, o nome do arquivo seria: Pedido_XXXX(Onde X seria o número do pedido que consta na célula C8, sendo que após salvar o contador aumentaria sequencialmente o número do pedido)_DD_MM_AAAA(Onde DD é o mês, MM é o mês e AAAA é o ano no qual o pedido foi aprovado). O segundo arquivo seria salvo apenas a guia order list no seguinte formato: Order_XXXX(Onde X seria o número do pedido que consta na célula C8 da guia cadastro)_AAAA_MM_DD(Onde DD é o mês, MM é o mês e AAAA é o ano no qual o pedido foi aprovado).

 
Postado : 19/05/2012 6:07 pm
(@felipesalomao)
Posts: 103
Estimable Member
Topic starter
 

Já Consegui resolver a questão nº 3, aos interessados a solução que encontrei foi usando o seguinte código na guia onde tem o botão para salvar os 2 arquivos:

Private Sub cmd_Salvar1_Click()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Call Módulo6.savebra
    Call CriaArquivo(Sheets("Order List"), ThisWorkbook.Path)
    Application.DisplayAlerts = True
End Sub

Em módulos criei 2 módulos

O primeiro (Para Salvar : o arquivo completo com o nome: Pedido 0001 - 20/05/2012 (onde 0001 é a célula C8))

Sub savebra()
     'Saves filename as value of A1 plus the current date
     
    Dim newFile As String, fName As String
    Application.ScreenUpdating = False
     ' Don't use "/" in date, invalid syntax
    fName = Range("C8").Text
     'Change the date format to whatever you'd like, but make sure it's in quotes
    newFile = "Pedido " & fName & " -" & " " & Format$(Date, "dd-mm-yyyy")
    ChDir _
    "C:UsersFelipeDesktopTesteProjeção de Custos e PlanejamentoTestes"
    ActiveWorkbook.SaveAs Filename:=newFile
    
End Sub

e o segundo módulo (Para Salvar apenas a guia Order List em um novo arquivo com o nome: Order 0001 - 2012/05/20 (onde 0001 é a célula C8)):

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

Dim sht As Worksheet
Dim fName As String
fName = Range("C8").Text
    Application.ScreenUpdating = False
    
    'Cria um novo arquivo excel
    Set NovoArquivoXLS = Application.Workbooks.Add
    
    'Copia a planilha para o novo arquivo criado
    mPlan.Copy Before:=NovoArquivoXLS.Sheets(1)
    Sheets("Plan1").Delete
    Sheets("Plan2").Delete
    Sheets("Plan3").Delete
    

    
    'Salva o arquivo
    NovoArquivoXLS.SaveAs mPathSave & "/" & "Order Number " & fName & " - " & Format$(Date, "yyyy-dd-mm")
    ActiveWorkbook.Close SaveChanges:=True
    
End Sub

Obs: Pelo código está configurado para salvar os 2 arquivos na pasta "C:UsersFelipeDesktopTesteProjeção de Custos e PlanejamentoTestes", sendo que ela pode ser alterada.

Agora só falta eu conseguir resolver a questão 1 e 2 (Consertar um bug e adicionar a função resetar linhas respectivamente ..)

Aguardo a ajuda.

Mt Obrigado.

 
Postado : 20/05/2012 12:08 am
(@felipesalomao)
Posts: 103
Estimable Member
Topic starter
 

Agora consegui finalizar de vez a dúvida 3, consegui adicionar o contador sequencial, na macro que salva o arquivo, no final coloquei o código:

Range("C8").Value = Range("C8").Value + 1 

Dessa forma ele salva com o nome Pedido 0001 - 20-05-2012 e automaticamente grava + 1 na sequência que consta na Célula 08 na guia Cadastro, dessa forma, quando for aprovar um novo pedido automaticamente irá salvar Pedido 0002 e assim por diante, agora só falta resolver mesmo as questões 1 e 2, especialmente a 2, pois a 1 eu adicionei um comando para ao abrir a planilha, automaticamente selecionar as células corretas.

Estava pensando em tipo salvar as guias ocultamente sem modificação nenhuma (como vem por default com linhas só de produtos não marcados, e ao apertar o botão ele sobrepõe essas guias ocultas zeradas sobre as guias originais, zerando qualquer modificação, não sei se o melhor caminho é esse. Conto com a ajuda de vocês.

 
Postado : 20/05/2012 2:25 pm
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Resolvendo pendencia 1:

Substitua o conteúdo do módulo 2 pelo código abaixo:

Sub Macro3()
    Dim L As Long
    Dim L1 As Long
    Application.ScreenUpdating = False
    '===========================================================
    For L = 22 To 5000
        If InStr(1, Cells(L, 2), "total", vbTextCompare) Then
            Rows(L - 1 & ":" & L - 1).EntireRow.Copy
            Rows(L - 1 & ":" & L - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            L1 = L
            Exit For
        End If
    Next
    '===========================================================
    Sheets("Impostos").Select
    For L = 13 To 5000
        If InStr(1, Cells(L, 2), "total", vbTextCompare) Then
            Rows(L - 1 & ":" & L - 1).EntireRow.Copy
            Rows(L - 1 & ":" & L - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Exit For
        End If
    Next

    '===========================================================
    Sheets("Estimativas Finais").Select
    For L = 13 To 5000
        If InStr(1, Cells(L, 2), "total", vbTextCompare) Then
            Rows(L - 1 & ":" & L - 1).EntireRow.Copy
            Rows(L - 1 & ":" & L - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Exit For
        End If
    Next
    '===========================================================
    Sheets("Order List").Select
    For L = 13 To 5000
        If InStr(1, Cells(L, 2), "total", vbTextCompare) Then
            Rows(L - 1 & ":" & L - 1).EntireRow.Copy
            Rows(L - 1 & ":" & L - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Exit For
        End If
    Next
    '===========================================================
    Sheets("Cadastro").Select
    Range("C" & L1 & ":F" & L1).ClearContents
End Sub
 
Postado : 20/05/2012 6:49 pm
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

O código estava ativando toda hora...
acrescentei uma condição para que o código só seja executado quando a célula ativa for a última do cadastro...

    Sub Macro3()
        Dim L As Long
        Dim L1 As Long
        Application.ScreenUpdating = False
        '===========================================================
        For L = 22 To 5000
            If InStr(1, Cells(L, 2), "total", vbTextCompare) Then
                If ActiveCell.Row <> L - 1 Then
                    Exit Sub
                End If
                Rows(L - 1 & ":" & L - 1).EntireRow.Copy
                Rows(L - 1 & ":" & L - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                L1 = L
                Exit For
            End If
        Next
        '===========================================================
        Sheets("Impostos").Select
        For L = 13 To 5000
            If InStr(1, Cells(L, 2), "total", vbTextCompare) Then
                Rows(L - 1 & ":" & L - 1).EntireRow.Copy
                Rows(L - 1 & ":" & L - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                Exit For
            End If
        Next

        '===========================================================
        Sheets("Estimativas Finais").Select
        For L = 13 To 5000
            If InStr(1, Cells(L, 2), "total", vbTextCompare) Then
                Rows(L - 1 & ":" & L - 1).EntireRow.Copy
                Rows(L - 1 & ":" & L - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                Exit For
            End If
        Next
        '===========================================================
        Sheets("Order List").Select
        For L = 13 To 5000
            If InStr(1, Cells(L, 2), "total", vbTextCompare) Then
                Rows(L - 1 & ":" & L - 1).EntireRow.Copy
                Rows(L - 1 & ":" & L - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                Exit For
            End If
        Next
        '===========================================================
        Sheets("Cadastro").Select
        Range("C" & L1 & ":F" & L1).ClearContents
    End Sub
 
Postado : 20/05/2012 7:28 pm
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Respondendo a pendencia 2:

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    While InStr(1, Range("B27"), "total", vbTextCompare) < 0 Or Range("B27") = ""
        Rows("27:27").Delete Shift:=xlUp
    Wend
    Range("C22:F26").ClearContents
    Application.EnableEvents = True
    Application.ScreenUpdating = True
 
Postado : 20/05/2012 7:47 pm
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Pessoal,

Utilizei a solução da 3ª Pergunta para um problema que eu tenho, só que no meu caso, eu preciso que ele atualise o Numero do Pedido da Planilha anterior e não na Nova que foi criada.
Incluí a seguinte linha para a macro reabrir o pedido anterior e atualizar o numero do pedido:

Workbooks.Open Filename:="C:Google DriveTalão de Pedido - Etelmar.xlsm"

Range("F4").Value = Range("F4").Value + 1

Só que ele não passa do Pedido numero 2, tipo, do Pedido 1 para o 2 atualiza legal, só que ele não vai do Pedido 2 para o Pedido 3. Alguem sabe me dizer porque?

 
Postado : 29/05/2012 4:57 pm
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Substitua sua macro por esta aqui:

Sub Salvar_Pedido()
     'Saves filename as value of A1 plus the current date
    Dim newFile As String, fName As String
    
    Application.ScreenUpdating = False
    
     ' Don't use "/" in date, invalid syntax
    fName = Range("F4").Text
    
     'Change the date format to whatever you'd like, but make sure it's in quotes
    newFile = "Pedido " & fName & " -" & " " & Format$(Date, "dd-mm-yyyy")
    
    ActiveSheet.Copy
    
    ChDir "C:Google DriveOrçamentos"
    Application.DisplayAlerts = False 'evita de mostrar o alerta se quer salvar o projeto sem o VBA anexo
    ActiveWorkbook.SaveAs Filename:=newFile
    Application.DisplayAlerts = True 'retorna ao normal os alertas do Excel
    
    ActiveWorkbook.Close
    Range("F4").Value = Range("F4").Value + 1
    ThisWorkbook.Save
End Sub
 
Postado : 31/05/2012 7:50 pm