Basole

@AdrianoKbcao use a funcao max para criar o sequencial. Ex.: Function GerarNumAutomatic() As Long Dim rngId As Range With ActiveSheet Set rngId = .Range(.Cells(2, 1), .Cells(.UsedRange.Rows.Count, 1)) GerarNumAutomatic = Application.WorksheetFunction.Max(rngId) + 1 End With End Function Sub Teste() ActiveCell.Value = GerarNumAutomatic End Sub

@Ma pelo que entendi, voce precisa de uma macro que automatize o seu trabalho manual de salvar como pdf e salvar cada sheet (aba) em uma nova pasta_de_trabalho com cada aba com dados e os graficos como img. Seria bom voce postar sua planilha ou um exemplo bem proximo com alguns dados ficiticios indicando o(s) intervalo(s) desejados.

cole o cod abaixo no modulo da sua aba Private Sub Worksheet_Activate() ' altere a celula desejada activeseet.Range("C1").Value = NomeUsuario End Sub

Boa tarde, Segue abaixo as alteraões: Private Sub SelecionarLinha_Click() Dim k As Range With ThisWorkbook.Sheets("ORÇAMENTO") Set k = .Range("A:C").Find(What:=Me.cbProduto.Text, LookIn:=xlValues, LookAt:=xlWhole) If Not k Is Nothing Then m = ActiveCell.Column .Activate .Cells(k.Row, m).Select Else MsgBox "Não encontrado!", 64, "Atenção" End If End With End Sub

Tarde @Juacgomes segue abaixo as alteraçõs solicitadas: Const strDados = ("Água; Pera; Uva; Banana") Const SuaColuna = "D" ' * ALTERE AQUI: sua Coluna Const LinhaInicial = 2 ' * ALTERE AQUI: Linha inicial (da coluna), que contem dados Sub Verificar_DadosContidos_() Dim i As Integer, lr As Long, PriEnd As String Dim strArray() As String, rng As Range, intCount As Integer With ActiveSheet lr = .Cells(Rows.Count, SuaColuna).End(xlUp).Row Set rng = .Range(.Cells(LinhaInicial, SuaColuna), .Cells(lr, SuaColuna)) rng.Offset(, 1).Value = 0 End With strArray = Split(strDados, "; ") For intCount = LBound(strArray) To UBound(strArray) Set rng = ActiveSheet.Columns(SuaColuna).Find(What:=Trim(strArray(intCount)), LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Not rng Is Nothing Then PriEnd = rng.Address Do rng.Offset(, 1).Value = 1 Set rng = ActiveSheet.Columns(SuaColuna).FindNext(after:=rng) If rng Is Nothing Then Exit Do Loop While Not rng Is Nothing And rng.Address <> PriEnd End If Next End Sub

Tarde, segue abaixo as alterações: Const NomeDaSuaAba = "* ALTERE AQUI e coloque o nome da sua ABA (entre aspas)" Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If Sheets(NomeDaSuaAba).Range("Q1").Text <> "300%" Then If MsgBox("Arquivo preenchido incorretamente, salvar mesmo assim? ", vbCritical + vbYesNo, "Aviso") = vbYes Then Cancel = False Exit Sub Else Cancel = True ThisWorkbook.Application.DisplayAlerts = False ThisWorkbook.Application.Quit End If End Sub End Sub

Este exemplo, cole em um modulo da sua Pasta_de_trabalho. E altere os dados no local indicado: Const strDados = ("Água; Pera; Uva") Const SuaColuna = "D" ' * ALTERE AQUI: sua Coluna Const LinhaInicial = 2 ' * ALTERE AQUI: Linha inicial (da coluna), que contem dados Sub Verificar_DadosContidos_() Dim i As Integer, lr As Long Dim strArray() As String, rng As Range, intCount As Integer With ActiveSheet lr = .cells(Rows.Count, SuaColuna).End(xlUp).Row Set rng = .Range(.cells(LinhaInicial, SuaColuna), .cells(lr, SuaColuna)) rng.Offset(, 1).Value = 0 End With strArray = Split(strDados, ";") For intCount = LBound(strArray) To UBound(strArray) Set rng = ActiveSheet.Columns(SuaColuna).Find(Trim(strArray(intCount))) If Not rng Is Nothing Then rng.Offset(, 1).Value = 1 End If Next End Sub

@FernandoCP veja este link, se lhe ajuda: AutoIt

Bom neste exemplo se a coluna AR um valor, for alterado (manualmente), o conteudo (valor) da respectiva linha da coluna F será inserida como valor, automaticamente. * Click com o botão direito sobre a Aba desejada, e selecione "Exibir Código" (vide img). Em seguida cole o codigo Exemplo (abaixo): Exemplo: Private Sub Worksheet_Change(ByVal Target As Range) Dim Lr As Long If Target.Count > 1 Then Exit Sub Lr = ActiveSheet.Cells(Rows.Count, "AR").End(xlUp).Row + 1 If Not Intersect(Target, Range("AR2:AR" & Lr)) Is Nothing Then With Target.Offset(, -38) .value = .value End With End If End Sub

@FMattos Como não fui eu quem desenvolveu esta planilha, fica difícil responder com exatidão sobre este problema. Mas tente então no userform chat "desfazer" isso: E em seguida declare cada variavel em seu proprio evento. Exemplo Dim sql as string

Sendo assim, substitua a macro anterior... por esta: Const NomeDaSuaAba = "* ALTERE AQUI e coloque o nome da sua ABA (entre aspas)" Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If Sheets(NomeDaSuaAba).Range("Q1").Text <> "300%" Then MsgBox "Arquivo preenchido incorretamente, não foi possível salvar e será fechado!", vbCritical, "Aviso" Cancel = True ThisWorkbook.Application.DisplayAlerts = False ThisWorkbook.Application.Quit End If End Sub

Siga este procedimento: Aperte as teclas ALT+F11, ao lado esquerdo (vide img) click duas vezes em EstaPasta_de_trabalho e no editor a direita cole o codigo que postei anteriormente: Private Sub Workbook_BeforeClose(Cancel As Boolean) 'Tenho uma planilha excel e só quero que o arquivo seja salvo se a célula Q1 seja igual a 300%, 'caso negativo aparecerá uma msgbox com o texto "Arquivo preenchido incorretamente, não foi possível salvar". If Sheets(" * AQUI O NOME DA SUA ABA").Range("Q1").Text <> "300%" Then MsgBox "Arquivo preenchido incorretamente, não foi possível salvar", vbCritical, "Aviso" Cancel = True End If End Sub Em seguida salve a planilha com a extensão xlsm (macros)

No proprio evento declare tambem esta variavel: Dim Sql as String

Pois é, este é o problema de não declarar todas as variaveis, em algumas maquinas até roda, outras não. Bom mas enfim, no top deste modulo declare esta variavel: Public Cnn As New ADODB.Connection.

Segue exemplo: Private Sub Workbook_BeforeClose(Cancel As Boolean) 'Tenho uma planilha excel e só quero que o arquivo seja salvo se a célula Q1 seja igual a 300%, 'caso negativo aparecerá uma msgbox com o texto "Arquivo preenchido incorretamente, não foi possível salvar". If Sheets(" * AQUI O NOME DA SUA ABA").Range("Q1").Text <> "300%" Then MsgBox "Arquivo preenchido incorretamente, não foi possível salvar", vbCritical, "Aviso" Cancel = True End If End Sub

Outra possibilidade a eliminar possiveis erros por falta de declaraçoes as variaveis: no userform que esta gerando erro. No topo do modulo coloque: Option Explicit Public Sql As String No evento: Private Sub CommandButton1_Click() Dim x As String No evento: Private Sub listar() Dim x As Integer

@FMattos eu sugiro fazer uma checagem geral eliminando as possibilidades. Por exemplo, verifique nas maquinas que estão apresentando este erro, se está instado no pacote office o Access. Caso não esteja será necessario a instalação de um patch.

@Arthur Ferreira não entendi o que quer dizer com "fazer pelo conteúdo" De qq. forma segue exemplo: Public Sub Separar_APosBarra() Dim sEqpE As String Dim sEqpD As String sEqpE = Left("INS-001/COM", InStr("INS-001/COM", "/") - 1) sEqpD = Right("INS-001/COM", Len("INS-001/COM") - InStr("INS-001/COM", "/")) MsgBox sEqpE & vbNewLine & sEqpD End Sub

Bom aqui pra mim esta funcionando sem errors. Eu fiz uns ajustes no codigo, baixe o anexo. data para expirar.zip

@Diego Dias Alano seja bem vindo ao forum. Veja se dessa forma lhe atende: Private Sub Workbook_Open() Dim exdate As Date 'data de expiração exdate = "09/08/2016" If Date > exdate Then varNum = Application.InputBox("A planilha expirou, informe o codigo", "Revalidação do prazo", "####") If varNum = 1234 Then Exit Sub End If MsgBox ("Você chegou no final do período de uso") ActiveWorkbook.Protect "1234" ThisWorkbook.Application.DisplayAlerts = False 'des. aviso de alerta ThisWorkbook.Application.Quit ' fecha a planilha automaticamente End If MsgBox ("Seja bem-vindo às Ordens de Produção") End Sub

voce pode colocar um botao para executar a macro e fazer um loop checar os valores dos checkbox, referenciando cada checkbox a cada linha de dados. Ex.: Private Sub CommandButton1_Click() Dim objCkBox As Object, sh As Worksheet, i As Long Set sh = Sheets("Nota") i = 2 If Not mBarEvents Then With Sheets("Ms40") For Each objCkBox In .OLEObjects If TypeName(objCkBox.Object) = "CheckBox" Then objCkBox.Object.Value = True sh.Range("A" & i).Value = .Range("B" & i).Value i = i + 1 End If Next objCkBox End With End If Application.ActiveWorkbook.RefreshAll End Sub

@jefferson simoes seja bem vindo ao forum. Segue um exempo, ao clicar o checkbox, a macro copia o conteudo da celula B2 (ms40) para celula A2 da aba nota Private Sub CheckBox1_Click() Dim sh As Worksheet Set sh = Sheets("Nota") With ThisWorkbook.Worksheets("MS40") If .OLEObjects("CheckBox1").Object.Value = True Then sh.Range("A2").Value = .Range("B2").Value End If End With End Sub

Até tentei lhe ajudar, mas minha maquina não conseguiu abrir sua planilha de 10MB.

Cole o cod. abaixo no modulo da sua planilha (aba). Private Sub Worksheet_Change(ByVal Target As Range) With Target If .Cells.Count > 1 Or .HasFormula Then Exit Sub On Error Resume Next If Not Intersect(Target, Range("A2:D9")) Is Nothing Then Application.EnableEvents = False .value = VBA.UCase(.value) Application.EnableEvents = True End If On Error GoTo 0 End With End Sub

@JorgeSouza Sim. Quais celulas deseja habilitar para maiusculo ?