Basole

@Maria Luiza Zapelini Tumelero se as celulas citadas em B ou D, forem bloqueadas o usuario em outro momento, não vai conseguir selecionar nada,ou seja não vai conseguir usar, a não ser inserindo a senha de desbloqueio/proteção. Fiz um exemplo, mas com as celulas B4 e D4 NÃO Bloqueadas para mostrar o funcionamento, protegendo os demais intervalos: C4 e E4:Y4 ao selecionar um determinado dado. Bloquear_Intervalo.zip

Veja se é isso que deseja.... Considerando que a celula em questão seja a A1 Na propriedade OpenAfterPublish:=False , alterei para falso, para não abrir o documento. Sub CONVERTER_PDF() Dim NomPastTrab As String NomPastTrab = [A1] ' Altere se necessario If VBA.Dir(ThisWorkbook.Path & "\" & NomPastTrab, vbDirectory) = Empty Then ' Se não existir a pasta NomPastTrab, cria VBA.MkDir ThisWorkbook.Path & "\" & NomPastTrab End If ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ ThisWorkbook.Path & "\" & NomPastTrab & "\" & NomPastTrab & ".pdf" _ , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _ :=False, OpenAfterPublish:=False ' True End Sub

@Maria Luiza Zapelini Tumelero pode-se usar o vba para automatizar esta tarefa. Se puder detalhar melhor os intervalos de celulas envoilvidos, tentaremos ajuda-la

@Zamboni_du experimente desta forma: Sub Localiza_palavra_desejada() Dim sbx As String Dim sSubs As String sbx = InputBox("Procurar palavra desejada") If sbx = cancel Then 'caso cancele a busca Exit Sub End If sSubs = InputBox("palavra que irá substituir") If sSubs = cancel Then 'caso cancele a busca Exit Sub End If ActiveSheet.UsedRange.Replace What:=sbx, Replacement:=sSubs MsgBox "Palavra [ " & sbx & " ] na célula [ " & ActiveCell.Address & " ], Substituida por " & sSubs, vbInformation End Sub

Veja se atende. A rotina chama a função que identifica o ip da maquina, e compara com o ip definido, Se for diferente protege todas as abas Sub Auto_open() Dim sh As Worksheet If getMyIP <> "192.168.01.10" Then ' * se for dif. protege todas as abas For Each sh In ThisWorkbook.Worksheets sh.Protect "1234" Next sh End If End Sub Public Function getMyIP() Dim objWMI As Object Dim objQuery As Object Dim objQueryItem As Object Dim vIpAddress Set objWMI = GetObject("winmgmts:\\.\root\cimv2") Set objQuery = objWMI.ExecQuery("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled = True") For Each objQueryItem In objQuery For Each vIpAddress In objQueryItem.ipaddress getMyIP = vIpAddress Exit For Next Next End Function

@Zamboni_du bom dia! tudo bem obrigado. Substitua a sub abaixo, no userform calendario: Sub ButtonClick(btn As MSForms.CommandButton) With btn If .Caption <> "" Then ' Me.TextBox1.Value = .Caption & "/" & VBA.Format(VBA.Month(VBA.DateValue("03/" & Me.CmbMonth.Value & "/2014")), "00") & "/" & Me.CmbYear.Value Me.TextBox1.Value = .Caption & "." & VBA.Format(VBA.Month(VBA.DateValue("03/" & Me.CmbMonth.Value & "/2014")), "00") & "." & Me.CmbYear.Value Unload Me End If End With End Sub

Experimente: Dim msg As String Dim i! For i = 9 To Cells(Rows.Count, "P").End(xlUp).Row msg = msg & Cells(i, "P") & vbNewLine Next i MsgBox "informações de um intervalo de linhas: " & VBA.vbNewLine & msg

@nickson.castro não tenho como testar aqui. Mas veja se funciona ai pra voce! Formulário_V1.zip

@Jbibs Veja se é isso que deseja Etiquetas do estoque - v6_.zip

Dá uma olhada neste link: vba-sendkeys-for-the-mac

Dá uma olhada neste link: vba-sendkeys-for-the-mac

Bom dia, veja se é isso que deseja Ao abrir a planilha a macro pergunta se deseja verificar o status das calibraçoes. Caso for afirmativo a macro varre todas as linhas com dados, verifica e caso status vencido (-30d) envia o email para o respectivo contato. Calibrações.zip

Se preferir um mais simples e ja habilitado inserir a data na celula. Exemplo_Calendario_POP-UP.zip

@Zamboni_du o inputbox não tem esse recurso e não é possível definir uma formatação, sem o uso de API. Acho que não compensa escrever tantas linhas de código para atender essa necessidade, além de tudo que pode ter problemas de rejeição, dependendo da versão do seu office, o uso de api. Minha sugestão é usar um calendário pop-up onde o usuário possa selecionar uma data válida sem gerar erros do tipo, 30/Fev/2021, data inválida. Segue link para download: Exemplo de calendário UserForm * Pode também, alterar os temas de acordo com seu gosto:

É possível. Copie a imagen do print e selecione a celula "C18" que automaticamente a macro cola (CTRL+V) e ajusta a imagem a janela Cole o codigo no modulo da respectiva planilha(aba) Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = "$C$18" Then On Error GoTo ER Excel.Application.EnableEvents = False Excel.Application.CutCopyMode = False ActiveSheet.Paste Selection.ShapeRange.LockAspectRatio = False Selection.ShapeRange.Top = (Target.Top - 6) Selection.ShapeRange.Left = (Target.Left - 1) Selection.ShapeRange.Width = Target.Resize(, 12).Width Selection.ShapeRange.Height = Target.Resize(5).Height - 3 ER: Excel.Application.EnableEvents = True End If End Sub

@RAIMUNDO LIMA DE ARAUJO obrigado! Substitua este trecho do codigo: Por este: ' deleta a img do intervalo Dim shape As shape For Each shape In .Shapes shape.Delete Next

@Martti é so acrescentar no codigo a linha ActiveSheet.PrintPreview Mas no caso teria que definir o intervalo para ser mostrado na tela, mas não esta disponibilizou essa informação

@Jorge Carneiro segue sugestão de acordo com as posições, a imagem da aba, postada Sub Inserir6ImgPorColuna6Linhas() Dim ArqSel As String Dim Celula As String Dim i As Long Dim n As Long Dim j As Long Dim myAr As Variant Dim dv As Double Dim ct As Integer Dim num As Double Dim msg As String Dim MyFolder As Object Dim FolderSelected msg = "Por favor, selecione a PASTA que contem os arq. de imagens" Set MyFolder = Application.FileDialog(msoFileDialogFolderPicker) With MyFolder .Title = msg .AllowMultiSelect = False If .Show <> -1 Then Exit Sub End If FolderSelected = .SelectedItems(1) If Not FolderSelected <> False Then MsgBox msg, 64, "Aviso" Exit Sub End If End With ArqSel = VBA.Dir(FolderSelected & "\") With ActiveSheet On Error GoTo Fin: Application.ScreenUpdating = False n = 1 ReDim myAr(n To 32) For i = 3 To 18 Step 3 For j = 1 To 16 Step 3 If n > 32 Then Exit For myAr(n) = .Cells(i, j).Address n = n + 1 Next Next i = 1 Do While Val(ct) < UBound(myAr) Celula = VBA.Replace(myAr(i), "$", "") .Shapes.AddPicture FolderSelected & "\" & ArqSel, False, True, .Range(Celula).Left, _ .Range(Celula).Top, _ .Range(Celula).Width + _ .Range(Celula).Offset(, 1).Width, _ .Range(Celula).Height ArqSel = VBA.Dir() i = i + 1 ct = ct + 1 dv = ct / 16 num = dv * 11 ' (abaixo ): barra de status Application.StatusBar = "Aguarde o Processamento:= Inserind.... " & _ ct & " de " & UBound(myAr) & " *.Jpg ......: " & _ "( " & VBA.Format(ct / UBound(myAr), "Percent") & " ) " & _ Application.Rept(VBA.ChrW(9632), num) DoEvents Loop End With Fin: Application.ScreenUpdating = True If VBA.Val(ct) < VBA.Val(1) Then MsgBox ct & " imagens foram inseridas!", 0, "Sucesso!" Else MsgBox ct & " imagens foram inseridas!", 0, "Sucesso!" End If Application.StatusBar = False End Sub

@GabrielTeixeira16 só com imagens acredito que fica difícil alguém lhe ajudar. Disponibilize um exemplo bem proximo do original, para que o pessoal faça as alteracoes que lhe atenda.

@Martti o que seria este print preview da Plan2 ? Explique melhor o que no voce está pensando

@RAIMUNDO LIMA DE ARAUJO segue uma opção como uso de SendKeys. Nesta oção o WhatsApp precisa estar conectado no seu PC * Testado com o uso do aplicativo para windows do WhatsApp app. DOWNLOAD PARA WINDOWS Agenda de tarefas diárias1.zip

@RAIMUNDO LIMA DE ARAUJO substitua no codigo, LIKE pelo sinal de igual ( = ). E a formatação do nome dos arquivos pdf, salvos tem que seguir um padrão, ou seja os espaços entre as variaveis (OR + NOME DO MOTORISTA + PLACA + TERMINAL) e os traços ( - ) tem que ser iguais na comparação.

@Marttiveja se é isso que deseja: Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim Lr! Dim sh2 As Worksheet Set sh2 = Worksheets("Plan2") Lr = Cells(Rows.Count, 1).End(xlUp).Row If Not Application.Intersect(Target, Range("A1:AH" & Lr)) Is Nothing Then sh2.Range("AP3").Value = Range("A" & Target.Row).Value2 If sh2.Range("AP3").Value = Range("A" & Target.Row).Value2 Then _ MsgBox "Ok", 64, "Aviso" End If End Sub

Ja corrigi esse erro testes.xls-v2.zip

@RAIMUNDO LIMA DE ARAUJO era um criterio agora é outro? Veja se entedi, segue o anexo testes.xls-v1.zip