nao sei mais o que fazer, ja tentei de varias maneiras e nada.
Porem dividi a macro em 2
Percebi que se eu rodar 10x somente a primeira macro " Processar ",todas as informacoes sao salvas na planilha Vendas Feitas sem erro algum !
Dai saiuo da Planilha e entro de novo, entao
Dai executo pela primeira vez , desta vez as duas Macros, 1 e 2, entao os dados sao salvos corretamente na aba Vendas Feitas. Entao tento excutar outra venda, a segunda vez, ai aparece a falha, ou seja, as macros rodam sem erro, porem as informacoes nao sao slavas na aba Vendas Feitas, pra nao dizer que nao salvou, salva somente esta parte:
' ROTINA VENDA1
'-------------------------------------------------
' PRIMEIRO PROCEDIMENTO
Dim Ws As Worksheet
Dim Dest As Range
Set Ws = Sheets("Vendas Feitas") 'Referencia a guia LANÇAR COMISSAO como Ws
Set Dest = Ws.Range("A3").Range("B50000").End(xlUp).Offset(1, -1) 'Encontra a ultima linha da guia comissão (definida como Dest)
Range("AA3:AM3").Copy 'Copia o intervalo
Dest.PasteSpecial xlPasteValues 'Cola valores na guia Comissão
Application.CutCopyMode = False
Set Ws = Nothing
Set Dest = Nothing
---------------------------------------------------------------------------------------------
a rotina de baixo nao salva nem a pau
A imprensao que da é que a memoria fica confusa, sei la, ou grava e apaga, ou embaralha.
------------------------------------------------------------------------------------------
' SEGUNDO PROCEDIMENTO
Set Ws = Sheets("Vendas Feitas") 'Referencia a guia LANÇAR COMISSAO como Ws
Set Dest = Ws.Range("N3").Range("B50000").End(xlUp).Offset(1, -1) 'Encontra a ultima linha da guia comissão (definida como Dest)
Range("BB3:BH3").Copy 'Copia o intervalo
Dest.PasteSpecial xlPasteValues 'Cola valores naguia Comissão
Application.CutCopyMode = False
Set Ws = Nothing
Set Dest = Nothing
For x = 4 To 17
If Range("BB" & x).Value <> "" Then
Set Ws = Sheets("Vendas Feitas") 'Referencia a guia Mais Vendidos como Ws2
Set Dest = Ws.Range("A3").Range("B50000").End(xlUp).Offset(1, -1) 'Encontra a ultima linha da guia comissão (definida como Dest)
Range("AO" & x & ":BH" & x).Copy 'Copia o intervalo
Dest.PasteSpecial xlPasteValues 'Cola valores na guia Comissão
Application.CutCopyMode = False
Set Ws = Nothing
Set Dest = Nothing
End If
Next
--------------------------------------------------------
Segue as duas Macros, lembrando que a dividi achando que iria resolver o problema, mas eu queria mesmo é ter uma unica Macro.
-----------------------------------------------------------
Macro Processar:
Sub Processar()
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'desabilite o alerta
Application.ScreenUpdating = False
Application.DisplayStatusBar = False 'Desabilita atualização da barra de status
'---------------------------------------------------------------------------------
Dim nome
nome = Range("B1").Value
Sheets("Vendas Feitas").Visible = True
Sheets(nome).Select
Sheets("Clientes").Visible = True
'-----------------------------------------------------------
If Range("B2").Value = "" Then
MsgBox ("INSIRA A EMPRESA !")
GoTo Terminar
Else
End If
If Range("B5").Value = "" Then
MsgBox ("INSIRA UM PRODUTO !")
GoTo Terminar
Else
End If
If Range("L2").Value = 1 Then
MsgBox ("ESCOLHA UM CLIENTE #1 !")
GoTo Terminar
Else
End If
If Range("U6").Value = 1 Then
MsgBox ("ESCOLHA A FORMA DE PAGAMENTO !")
GoTo Terminar
Else
End If
Sheets("Lancamentos Entrada & Saida").Unprotect "123"
Sheets("Ranking").Unprotect "123"
If Range("B1").Value = "Venda1" Then
Dim x As Integer
Sheets("Vendas Feitas").Visible = True
'--------------------------------------------------------------------------------------
' ROTINA VENDA1
'-------------------------------------------------
' PRIMEIRO PROCEDIMENTO
Dim Ws As Worksheet
Dim Dest As Range
Set Ws = Sheets("Vendas Feitas") 'Referencia a guia LANÇAR COMISSAO como Ws
Set Dest = Ws.Range("A3").Range("B50000").End(xlUp).Offset(1, -1) 'Encontra a ultima linha da guia comissão (definida como Dest)
Range("AA3:AM3").Copy 'Copia o intervalo
Dest.PasteSpecial xlPasteValues 'Cola valores na guia Comissão
Application.CutCopyMode = False
Set Ws = Nothing
Set Dest = Nothing
' SEGUNDO PROCEDIMENTO
Set Ws = Sheets("Vendas Feitas") 'Referencia a guia LANÇAR COMISSAO como Ws
Set Dest = Ws.Range("N3").Range("B50000").End(xlUp).Offset(1, -1) 'Encontra a ultima linha da guia comissão (definida como Dest)
Range("BB3:BH3").Copy 'Copia o intervalo
Dest.PasteSpecial xlPasteValues 'Cola valores naguia Comissão
Application.CutCopyMode = False
Set Ws = Nothing
Set Dest = Nothing
For x = 4 To 17
If Range("BB" & x).Value <> "" Then
Set Ws = Sheets("Vendas Feitas") 'Referencia a guia Mais Vendidos como Ws2
Set Dest = Ws.Range("A3").Range("B50000").End(xlUp).Offset(1, -1) 'Encontra a ultima linha da guia comissão (definida como Dest)
Range("AO" & x & ":BH" & x).Copy 'Copia o intervalo
Dest.PasteSpecial xlPasteValues 'Cola valores na guia Comissão
Application.CutCopyMode = False
Set Ws = Nothing
Set Dest = Nothing
End If
Next
GoTo Fim_Vendas
Else
End If
'--------------------------------------------------------------------------------------
' ROTINA VENDA2
'--------------------------------------------------------------------------------------
If Range("B1").Value = "Venda2" Then
'Run "Venda2"
Set Ws = Sheets("Vendas Feitas") 'Referencia a guia LANÇAR COMISSAO como Ws
Set Dest = Ws.Range("A3").Range("B50000").End(xlUp).Offset(1, -1) 'Encontra a ultima linha da guia comissão (definida como Dest)
Range("AA3:AM3").Copy 'Copia o intervalo
Dest.PasteSpecial xlPasteValues 'Cola valores na guia Comissão
Application.CutCopyMode = False
Set Ws = Nothing
Set Dest = Nothing
' SEGUNDO PROCEDIMENTO
Set Ws = Sheets("Vendas Feitas") 'Referencia a guia LANÇAR COMISSAO como Ws
Set Dest = Ws.Range("N3").Range("B50000").End(xlUp).Offset(1, -1) 'Encontra aultima linha da guia comissão (definida como Dest)
Range("BB3:BH3").Copy 'Copia o intervalo
Dest.PasteSpecial xlPasteValues 'Cola valores naguia Comissão
Application.CutCopyMode = False
Set Ws = Nothing
Set Dest = Nothing
'---------------------------------------------------
' Dim x As Integer
For x = 4 To 17
If Range("BB" & x).Value <> "" Then
Set Ws = Sheets("Vendas Feitas") 'Referencia a guia Mais Vendidos como Ws2
Set Dest = Ws.Range("A3").Range("B50000").End(xlUp).Offset(1, -1) 'Encontra a ultima linha da guia comissão (definida como Dest)
Range("AO" & x & ":BH" & x).Copy 'Copia o intervalo
Dest.PasteSpecial xlPasteValues 'Cola valores na guia Comissão
Application.CutCopyMode = False
Set Ws = Nothing
Set Dest = Nothing
End If
Next
GoTo Fim_Vendas
Else
End If
'--------------------------------------------------------------------------------------
' ROTINA VENDA3
'--------------------------------------------------------------------------------------
If Range("B1").Value = "Venda3" Then
'-------------------------------------------------
' PRIMEIRO PROCEDIMENTO
Set Ws = Sheets("Vendas Feitas") 'Referencia a guia LANÇAR COMISSAO como Ws
Set Dest = Ws.Range("A3").Range("B50000").End(xlUp).Offset(1, -1) 'Encontra a ultima linha da guia comissão (definida como Dest)
Range("AA3:AM3").Copy 'Copia o intervalo
Dest.PasteSpecial xlPasteValues 'Cola valores na guia Comissão
Application.CutCopyMode = False
Set Ws = Nothing
Set Dest = Nothing
'--------------------------------------------------
' SEGUNDO PROCEDIMENTO
Set Ws = Sheets("Vendas Feitas") 'Referencia a guia LANÇAR COMISSAO como Ws
Set Dest = Ws.Range("N3").Range("B50000").End(xlUp).Offset(1, -1) 'Encontra a ultima linha da guia comissão (definida como Dest)
Range("BB3:BH3").Copy 'Copia o intervalo
Dest.PasteSpecial xlPasteValues 'Cola valores naguia Comissão
Application.CutCopyMode = False
Set Ws = Nothing
Set Dest = Nothing
'---------------------------------------------------
' Dim x As Integer
For x = 4 To 17
If Range("BB" & x).Value <> "" Then
Set Ws = Sheets("Vendas Feitas") 'Referencia a guia Mais Vendidos como Ws2
Set Dest = Ws.Range("A3").Range("B50000").End(xlUp).Offset(1, -1) 'Encontra a ultima linha da guia comissão (definida como Dest)
Range("AO" & x & ":BH" & x).Copy 'Copia o intervalo
Dest.PasteSpecial xlPasteValues 'Cola valores na guia Comissão
Application.CutCopyMode = False
Set Ws = Nothing
Set Dest = Nothing
End If
Next
Else
End If
GoTo Fim_Vendas
Fim_Vendas:
'---------------------------------------------------------------------
' Parte 2
'---------------------------------------------------------------------
'Sheets("VENDAS FEITAS").Visible = False
Sheets(nome).Select
'--------------------------------------------------
' Gerar Vendas ao Cliente
'--------------------------------------------------
Dim WC, WR As Worksheet
Dim Cont As Long
Dim Venda As String
' Application.ScreenUpdating = False
Set WC = Worksheets("CLIENTES")
Set WR = Worksheets(nome)
Venda = WR.Range("L6").Value
Sheets("CLIENTES").Visible = True
WC.Activate
WC.Range("B3").Activate
Do While ActiveCell <> ""
If ActiveCell = Venda Then
ActiveCell.Offset(0, 18).Activate
Cont = ActiveCell
Cont = Cont + 1
ActiveCell = Cont
Else
ActiveCell.Offset(1, 0).Activate
End If
Loop
WR.Activate
Set WC = Nothing
Set WR = Nothing
Application.CutCopyMode = False
Sheets("Tela de Finalizacao").Select
GoTo Terminar
Terminar:
End Sub
Macro Processar 2
Sub Processar2()
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'desabilite o alerta
Application.ScreenUpdating = False
Application.DisplayStatusBar = False 'Desabilita atualização da barra de status
'---------------------------------------------------------------------------------
Sheets("Venda1").Select
'-----------------------------------------------------------------------
'Parte 3
'-----------------------------------------------------------------
'PRODUTOS MAIS VENDIDOS
' Pocisionar Produto no Ranking
Dim Produto As String, VendaAba As String
Dim Cont1 As Long, xb As Integer
Dim WC1 As Worksheet, WR1 As Worksheet
VendaAba = Range("B1").Value
Set WC1 = Worksheets("Ranking")
Set WR1 = Worksheets(VendaAba)
Produto = WR1.Range("F71").Value
VOLTAR:
WC1.Activate
WC1.Range("B2").Activate
Do While ActiveCell <> ""
If ActiveCell = Produto Then
ActiveCell.Offset(0, 1).Activate
Cont1 = ActiveCell
Cont1 = Cont1 + WR1.Range("G" & xb).Value '+ 1
ActiveCell = Cont1
Else
ActiveCell.Offset(1, 0).Activate
End If
Loop
'---------------------------------------
WR1.Activate
'Aqui faz uma verificacao se existem outros produtos
For xb = 72 To 86
If Range("F" & xb).Value <> "" And Range("I" & xb).Value = 0 Then
Produto = WR1.Range("F" & xb).Value
Range("I" & xb).Value = 1 'Aqui escrevo 1 para marcar que essa rotina foi comprida !
GoTo VOLTAR
End If
Next
Set WC1 = Nothing
Set WR1 = Nothing
'-------------------------------------------------------------------------------
'Parte 4
'-----------------------------------------------------------------------
'Aqui Atualiza os produtos no Estoque que foram vendidos
Sheets("LANCAMENTOS ENTRADA & SAIDA").Visible = True
' ATUALIZAR ESTOQUE DE PRODUTOS
'Declaração de Variaveis para transferir os dados de Vendas1 para Vendas Feitas
'---------------------------------------------
Dim xy As Integer
Dim Ps As Worksheet
Dim TsDest As Range
For xy = 72 To 86
If Range("D" & xy).Value <> "" Then
Set Ps = Sheets("LANCAMENTOS ENTRADA & SAIDA") 'Referencia a guia Mais Vendidos como Ws3
Set TsDest = Ps.Range("A2").Range("B20000").End(xlUp).Offset(1, -1) 'Encontra a ultima linha da guia comissão (definida como Dest)
Range("D" & xy & ":H" & xy).Copy 'Copia o intervalo
TsDest.PasteSpecial xlPasteValues 'Cola valores na guia Comissão
Application.CutCopyMode = False
Set Ps = Nothing
Set TsDest = Nothing
End If
Next
'-------------------------------------------------
Sheets("LANCAMENTOS ENTRADA & SAIDA").Select
Range("A1:E30808").Activate
ActiveWorkbook.Worksheets("LANCAMENTOS ENTRADA & SAIDA").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("LANCAMENTOS ENTRADA & SAIDA").Sort.SortFields.Add Key:=Range _
("A2:A15583"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("LANCAMENTOS ENTRADA & SAIDA").Sort
.SetRange Range("A1:E15583")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("F4").Activate
' Sheets(nome).Select
Sheets("Venda1").Select
Sheets("LANCAMENTOS ENTRADA & SAIDA").Visible = False
'----------------------------------------------------------------------------
'Parte 5
'----------------------------------------------------------------------------
Range("B2").Value = 1
Range("B5:B33").Value = ""
Range("U6").Value = 1
Range("L15:N15").Value = ""
Range("S20").Value = ""
Range("L26:L30").Value = ""
Range("Q26:Q30").Value = ""
Range("L2").Value = 1
Range("B2").Value = ""
Range("I72:I86").Value = ""
Range("K5:K34").Value = ""
Sheets("Ranking").Protect "123"
'----------------------------------------------------------------------------
'Parte 6
'----------------------------------------------------------------------------
Sheets("Venda1").Select
'-------------------------------------------------------
Sheets("Venda1").Unprotect "123"
'---------------------------------------------------
'Gerar Recibo de vendas
t = ActiveSheet.Range("D1")
a = t + 1
Application.ActiveSheet.Range("D1").Value = a
'--------------------------------------------------
Sheets("Venda1").Protect "123"
'---------------------------------------------------------------------
'Parte 7
'---------------------------------------------------------------------
' On Error Resume Next
' Dim Caminho As String 'declaracao da variável caminho
' Caminho = "C:UsersAndreDesktopGerenciadorGerenciador"
' ActiveWorkbook.SaveAs Filename:=Caminho & ".xlsm"
' MsgBox ("A Planilha foi Salva")
'------------------------------------------------------------------
'Temporizador
Sheets("Tela de Finalizacao").Select
'Application.Wait VBA.Now + TimeValue("00:00:02")
'GoTo Terminar
'Terminar:
Application.CutCopyMode = False
'-------------------------------------------------------------
Application.ScreenUpdating = True
Application.DisplayAlerts = True 'desabilite o alerta
Application.ScreenUpdating = True
Application.DisplayStatusBar = True 'Desabilita atualização da barra de status
End Sub
Postado : 24/09/2016 6:35 pm