Basole

Veja o exemplo de pesquisa do registro, e caso já exista mostra a mensagem, e limpa os campos (TexttBox). Private Sub Btn_Salvar_Click() ConectDB rs.Open "Select * FROM [tb_usuarios] WHERE [Codigo]=" & Me.Txt_ID.Value, db, 3, 3 If rs.EOF Then rs.AddNew rs!Codigo = Me.Txt_ID.Value rs!Usuarios = Me.Txt_usuario.Value rs!Senha = Me.Txt_senha.Value rs.Update MsgBox "Registrado Com Sucesso!", vbInformation, "REGISTRADO" Else MsgBox "ID ja existir no BD", vbInformation, "Aviso" Me.Txt_ID.Value = "" Me.Txt_usuario.Value = "" Me.Txt_senha.Value = "" End If FechaDb End Sub

Sim pode salvar em qualquer pasta pois e um arquivo temporario. Tem o comando kill que deleta, apos inserir a imagem na planilha. Use este exemplo acima que funcionará para qualquer usuário e PC.

suaImagem(i) = Thisworkbook.path & "\" & "ImageFoto" & i & ".jpg" @Nadjala qual foi o erro ? Se foi relacionado ao caminho/diretório tens que colocar um endereço válido na sua máquina, como comentei no código exemplo Para todos usuários pode armazenar, temporariamente na mesma pasta da pasta_de_trabalho. Exemplo acima

@Nadjala precisa referenciar o local onde esta o image activeX pois a rotina esta em um modulo, fora do userform E como são 8 imagens usei o For, para inserir dinamicamente as imagens nos activeX que estão na planilha Private Sub nova_imagem() Dim i As Long Dim suaImagem(8) As String With ThisWorkbook .Activate With .Worksheets("MANUTENÇÃO") .Activate For i = 1 To 8 ' *Altere o caminho e nome da imagem de acordo com seus dados suaImagem(i) = "C:\Temp\" & "ImageFoto" & i & ".jpg" SavePicture UserForm2.Controls("Image" & i).Picture, suaImagem(i) .OLEObjects("ImageFoto" & i).Object.Picture = LoadPicture(suaImagem(i)) VBA.Kill suaImagem(i) Next End With End With End Sub * Seria bom acrescentar uma forma de validacao, para que o usuario insira todas as imagens no userform, caso contrario, ocorrerá erros, na hora que for inserir as imagens na planilha.

@Nadjala a sua pergunta inicial, eu fui alem e apresentei um exemplo genérico. Mas como você são conseguiu adaptar, sugiro que anexe o seu arquivo ou um exemplo bem próximo, para que possamos encontrar o erro e atender a sua demanda * O Fórum não aceita anexos com extensão: " *.xlsm ". Compacte (zipe) seu arquivo, antes de anexar.

@Nadjala sim é possivel. Segue exemplo: Private Sub CommandButton1_Click() 'Altere o caminho e nome da imagem de acordo com seus dados Const suaImagem As String = "C:\Temp\" & "NomedaSuaImagemdoUserform" & ".jpg" SavePicture Me.Image1.Picture, suaImagem 'Altere de acordo c/ seus dados? ThisWorkbook.Worksheets(1).Image1.Picture = LoadPicture(suaImagem) VBA.Kill suaImagem End Sub

@Lilia Iris Parise veja se é isso que deseja. Click no botao Todos para testar. reciboteste.zip

Quanto a primeira questão acredito que somente com um aplicativo de terceiros tipo spy. Na segunda, voce pode usar o armazenamento de dados ocultos do Excel para compartilhar dados entre projetos VBA. Exemplos: Na primeira Pasta_de_trabalho, voce insere os dados que ficarão armazenados (ocultos): Para escrever dados ocultos:: Application.ExecuteExcel4Macro "SET.NAME(""MeuParametro"", ""Parametro 1"")" Na segunda Pasta_de_trabalho, para ler dados ocultos armazenados (o parametro) Private Sub Workbook_Open() On Error Resume Next MsgBox Application.ExecuteExcel4Macro("MeuParametro") On Error GoTo 0 End Sub Esses dados ocultos ficam armazenados ate quando todas as estancias do Excel forem fechadas. Ou para deletar: On Error Resume Next ' exclui valor armazenado ocultos no Excel. Application.ExecuteExcel4Macro "SET.NAME(""MeuParametro"")" On Error GoTo 0

Veja o exemplo. Considerando que os dados estão dispostos na coluna A e comecam pela linha 2 Sub InserirCélulaAposRepetição() Dim i As Long Dim LR As Long LR = Cells(Rows.CountLarge, "A").End(xlUp).Row For i = LR To 2 Step -1 If i = LR Then If Application.WorksheetFunction.CountIf(Range("A2:A" & i), _ Range("A" & i).Value2) > 1 Then Cells(i + 1, "A").Value2 = "TEXTO" End If If i = 2 Then ElseIf Cells(i, "A") <> Cells(i - 1, "A") Then Cells(i, "A").Insert Cells(i, "A").Value2 = "TEXTO" Cells(i, "A").Font.Bold = True End If Next i End Sub

Veja o exemplo. * Acrescente no codigo ActiveSheet.AutoFilterMode = False pois se os filtros estiverem halibitados não serão encontrados Private Sub Alteração_Click() Dim rng As Range Dim UL As Long UL = Plan1.Cells(Plan1.Rows.CountLarge, 1).End(xlUp).Row Set rng = Plan1.Range("A2:A" & UL).Find(What:=Me.txt_ID.Text, LookIn:=xlValues, LookAt:=xlWhole, _ MatchCase:=False, SearchFormat:=False) If Not rng Is Nothing Then MsgBox " Dados Encontrados na linha: " & rng.Row With Plan1 .Range("B" & rng.Row) = Me.txt_titulo.Text .Range("C" & rng.Row) = Me.txt_numero.Text .Range("D" & rng.Row) = VBA.Format(Me.txt_data.Value, "dd/mm/ýyyy") .Range("E" & rng.Row) = txt_Licenciadora.Text .Range("F" & rng.Row) = Me.txt_Editora.Text End With Else MsgBox " Dados NAO Encontrados!!, Verifique" End If i = Plan1.Cells(Cells.Rows.Count, "a").End(xlUp).Row + 1 i = Plan1.Cells(Cells.Rows.Count, "a").End(xlUp).Row + 1 For j = 2 To i If CInt(txt_ID) = CInt(Plan1.Cells(i, 1)) Then Plan1.Cells(i, 2) = UCase(txt_titulo) Plan1.Cells(i, 3) = UCase(txt_numero) Plan1.Cells(i, 4) = UCase(txt_data) Plan1.Cells(i, 5) = UCase(txt_Licenciadora) Plan1.Cells(i, 6) = UCase(txt_Editora) Exit For End If Next For i = 1 To ListView1.ListItems.Count If ListView1.ListItems.Item(i) = txt_ID Then ListView1.ListItems.Item(i).SubItems(1) = UCase(txt_titulo) ListView1.ListItems.Item(i).SubItems(2) = UCase(txt_numero) ListView1.ListItems.Item(i).SubItems(3) = UCase(txt_data) ListView1.ListItems.Item(i).SubItems(4) = UCase(txt_Licenciadora) ListView1.ListItems.Item(i).SubItems(5) = UCase(txt_Editora) Exit For End If Next End Sub

Use o find para encontar o dado na planilha, a partir dai voce terá a referencia da linha Set Rng = .Range("A2:A1000").Find(What:= Me.txt_ID.Text, LookIn:=xlValues, LookAt:=xlWhole, _ MatchCase:=False, SearchFormat:=False)

@DaviCN anexe o seu arquivo ou um modelo bem próximo do original, pois parte do códico que postou está confuso.

Veja este exemplo....após 2 minutos de inatividade a pasta de trabalho (livro/book, etc), fecha automaticamente. AutoShutdown.zip

Experimente usar o Find, exemplo: Set Rng = .Range("AN2:BR1000").Find(What:=Me.txt_data.Text, LookIn:=xlValues, LookAt:=xlWhole, _ MatchCase:=False, SearchFormat:=False)

Experimente ThisWorkbook.Sheets(Array("Plan1", "Plan2", "Plan3")).Select ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=Diretorio & Application.PathSeparator & "Plan1_Plan2_Plan3" _ , Quality:=xlQualityMinimum, OpenAfterPublish:=False ThisWorkbook.Sheets("Plan1").Select

Envie o seu arquivo para testarmos e ver se o problema e com o mesmo, ou as configuracoes de segurança do seu aplicativo.

Segue o arquivo com as alteracoes indicadas no meu post anterior lottery21.zip

@rod2009rod nos testes que fiz com o arquivo txt "euro190 (1)", que enviou, nao apresentou esta inconsistencia. De qualquer forma, experimente alterar tambem esta linha na funcao clearFillArea dentro do formulario (userForm) With shFill.Range("C6:AM21")

@rod2009rod a planilha que voce anexou, esta no formato *xlsx, por tanto não contem as macros e nem a tela citada. *Compacte o seu aquivo na extencão *.xlsm, para conseguir anexar aqui no forum.

Experimente esta alteracão: Function clearFillArea() shFill.Range("A1:AT21").ClearContents With shFill.Range("C6:AM21") .Font.Name = "Wingdings" .Font.Size = 14 .Font.Color = vbBlack .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter ''.Interior.Color = vbWhite End With End Function

Veja se esta sugestao lhe atende, juntar as duas macros "Aprovacao e Tesouraria" Desta forma ja referencia o nome da nova aba criada na formula: Sub CRIAR_NOVA() 'CRIA NOVA PLANILHA DE DIA AO FINAL Dim CriaNovaAprovacao As String Dim CriaNovaTesouraria As String ThisWorkbook.Activate On Error GoTo MSGERRO: CriaNovaAprovacao = InputBox("DIGITE A DATA DA PLANILHA A SER CRIADA(DDMM_APROVACAO)", _ "CRIANDO NOVA ABA APROVACAO", VBA.Format(VBA.Date, "ddmm") & "_APROVACAO") If CriaNovaAprovacao = "" Then MsgBox "Operacao Cancelada!", 64, "Aviso": Exit Sub Sheets("MODELO APROV").Visible = True Sheets("MODELO APROV").Select Sheets("MODELO APROV").Copy After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count) ThisWorkbook.ActiveSheet.Name = CriaNovaAprovacao Sheets("MODELO APROV").Visible = False Sheets("HOME").Select MsgBox ("PLANILHA: " & CriaNovaAprovacao & " CRIADA COM SUCESSO") If Err.Number <> 0 Then MSGERRO: MsgBox ("DATA SOLICITADA JÁ EXISTE, POR FAVOR REINICIE O PROCESSO") With ThisWorkbook .Sheets("MODELO APROV (2)").Delete .Sheets("MODELO APROV").Visible = False .Sheets("HOME").Select End With On Error GoTo 0 Exit Sub End If 'CRIA NOVA PLANILHA TESOURARIA DE DIA AO FINAL On Error GoTo MSGERRO2: CriaNovaTesouraria = InputBox("DIGITE A DATA DA PLANILHA A SER CRIADA(DDMM_APROVACAO)", _ "CRIANDO NOVA ABA TESOURARIA", VBA.Format(VBA.Date, "ddmm") & "_TESOURARIA") If CriaNovaTesouraria = "" Then MsgBox "Operacao Cancelada!", 64, "Aviso": Exit Sub With ThisWorkbook .Sheets("MODELO TES").Visible = True .Sheets("MODELO TES").Select .Sheets("MODELO TES").Copy After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count) End With ThisWorkbook.ActiveSheet.Name = CriaNovaTesouraria Sheets("MODELO TES").Visible = False With ActiveSheet .Range("E3:E13").Select Selection.ClearContents .Range("E3").Select ActiveCell.FormulaR1C1 = _ "='" & CriaNovaAprovacao & "'!R[2]C[-2]+'" & CriaNovaAprovacao & "'!R[3]C[-2]" .Range("E4").Select ActiveCell.FormulaR1C1 = "='" & CriaNovaAprovacao & "'!R[3]C[-2]" .Range("E5").Select ActiveCell.FormulaR1C1 = _ "='" & CriaNovaAprovacao & "'!R[7]C[-2]+'" & CriaNovaAprovacao & "'!R[8]C[-2]" .Range("E6").Select ActiveCell.FormulaR1C1 = "='" & CriaNovaAprovacao & "'!R[8]C[-2]" .Range("E7").Select ActiveCell.FormulaR1C1 = _ "='" & CriaNovaAprovacao & "'!R[12]C[-2]+'" & CriaNovaAprovacao & "'!R[13]C[-2]" .Range("E8").Select ActiveCell.FormulaR1C1 = "='" & CriaNovaAprovacao & "'!R[13]C[-2]" .Range("E9").Select ActiveCell.FormulaR1C1 = _ "='" & CriaNovaAprovacao & "'!R[17]C[-2]+'" & CriaNovaAprovacao & "'!R[18]C[-2]" .Range("E10").Select ActiveCell.FormulaR1C1 = "='" & CriaNovaAprovacao & "'!R[18]C[-2]" .Range("E11").Select ActiveCell.FormulaR1C1 = _ "='" & CriaNovaAprovacao & "'!R[22]C[-2]+'" & CriaNovaAprovacao & "'!R[23]C[-2]" .Range("E12").Select ActiveCell.FormulaR1C1 = "='" & CriaNovaAprovacao & "'!R[23]C[-2]" .Range("E13").Select ActiveCell.FormulaR1C1 = "='" & CriaNovaAprovacao & "'!R[30]C[-2]" .Range("E14").Select ActiveWindow.LargeScroll Down:=1 .Range("E40").Select ActiveWindow.LargeScroll Down:=-1 .Range("E14").Select End With Sheets("HOME").Select MsgBox ("PLANILHA: " & CriaNovaTesouraria & " CRIADA COM SUCESSO") Exit Sub MSGERRO2: MsgBox ("DATA SOLICITADA JÁ EXISTE, POR FAVOR REINICIE O PROCESSO") With ThisWorkbook .Sheets("MODELO TES (2)").Delete .Sheets("MODELO TES").Visible = False .Sheets("HOME").Select End With End Sub

Bom realmente fica difícil ajudar sem mais informações e somente imagem de uma tabela com dados. Mas para nao disser que ano quero ajudar, segue um exemplo genérico de envio de dados no Access, Altere as informações no codigo de acordo com seus dados. * Em um modulo padrão: Const s_Tabela As String = "NOME DA SUA TABELA" Const s_bd As String = "NOME DO BANCO DE DADOS.mdb" Sub INSERIR_DADOS_ACCESS(shName As String) Dim strConnectString As String Dim objConnection As Object Dim strDbPath As String Dim strTblName As String Dim strSQL As String Dim ws As Worksheet Dim ErrorMessage Dim i As Integer Dim lastRow As Long Set objConnection = CreateObject("ADODB.Connection") strDbPath = ThisWorkbook.Path & "\" & s_bd '================================================== strConnectString = "Provider = Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & strDbPath & ";" On Error GoTo ErrorMessage With objConnection .Open strConnectString Set ws = ThisWorkbook.Worksheets(shName) lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row For i = 2 To lastRow .Execute "INSERT INTO " & s_Tabela & _ " (MONTH_, WEEK_, DAY_, TURNO, BANCADA, FERT, MODEL, BASIC, IMEI, INSPECAO, RESULT, ETC, ETC1, ETC2, ABA)" & _ " VALUES (" & ws.Cells(i, "A").Value & ", '" & ws.Cells(i, "B").Value & "', '" & VBA.Format(ws.Cells(i, "C").Value2, "dd/mm/yyyy") & _ "', " & ws.Cells(i, "D").Value & ", '" & ws.Cells(i, "E").Value & "', '" & ws.Cells(i, "F").Value & "', '" & _ ws.Cells(i, "G").Value & "', '" & ws.Cells(i, "H").Value & "', " & ws.Cells(i, "I").Text & ", '" & _ ws.Cells(i, "J").Value & "', '" & ws.Cells(i, "K").Value & "', '" & ws.Cells(i, "L").Value & "', '" & _ ws.Cells(i, "M").Value & "', '" & ws.Cells(i, "N").Value & "', '" & ws.Name & "')" Next i End With Set objConnection = Nothing Exit Sub ErrorMessage: MsgBox "OPIS: " & Err.Description & Chr(10) & _ "NUMER: " & Err.Number Set objConnection = Nothing End Sub * No modulo de EstaPasta_de_trabalho: Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim sh As Integer Dim ws As Worksheet For sh = 1 To ThisWorkbook.Worksheets.Count Set ws = ThisWorkbook.Worksheets(sh) ' AQUI ACRESCENTE OS SEUS CRITERIOS DE ACORDO COM A NECESSIDADE: _ EXCEMPLO: If ws.Name Like "Nome da Aba" Or ws.Name Like "Nome da aba 2" Then INSERIR_DADOS_ACCESS (ws.Name) End If Next sh End Sub Quando fechar a pasta de trabalho a macro envia automaticamente, os dados novos caso as condicoes sejam verdadeiras

Aqui pra mim funcionou perfeitamente @osvaldomp Apenas este cnpj '01680935000129 que a formula retornou outros dados alem da razão social. Ou seja não saiu com a formatacão desejada. Mas acredito que é por causa da pontuacao contida no nome da empresa. Mas são varios os motivo para retornar o erro #VALOR @Patropi. Por exemplo o cnpj nào pode ter pontuacão como: ponto, barra ou traco. Tem que inserir como texto, ou com aspas simples antes do numero. Outro motivo que pode retornar o erro e que a consulta gratuita tem limites, veja o quadro abaixo do site: http://receitaws.com.br

@DricaBernardes post seu código para que o pessoal ajude a adaptar.

@Noullan anexe um exemplo do Excel, com alguns dados ficticios para que o pessoal entenda melhor, e possa lhe ajudar nesta demanda.