Basole

@Alexandreudi da uma ollhada neste post

Segue opcao com macro. Veja se e isso que deseja. Sub Concatenar_linha_tiver_o_mesmo_código() Dim ws1 As Worksheet Dim i As Long Dim Lr As Long Dim sNom As String Dim end1 As Range Dim end2 As Range Dim cell As Range Dim arr() As String Dim tmp As String Set ws1 = ThisWorkbook.Sheets("Plan1") With ws1 Lr = .Range("A" & .Rows.Count).End(xlUp).Row For Each cell In .Range("A2:A" & Lr) If (cell <> "") And (VBA.InStr(tmp, cell) = 0) Then tmp = tmp & cell & "|" End If Next cell If VBA.Len(tmp) > 0 Then tmp = VBA.Left(tmp, VBA.Len(tmp) - 1) arr = VBA.Split(tmp, "|") For i = 0 To UBound(arr) Set end1 = .Columns(1).Find(What:=arr(i), _ LookIn:=xlValues, LookAt:=xlWhole, _ SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Not end1 Is Nothing Then Set end2 = end1 sNom = sNom & "," & VBA.Trim(end1.Offset(, 1).Value) Do Set end1 = ws1.Columns(1).FindNext(After:=end1) If Not end1 Is Nothing Then If end1.Address = end2.Address Then Exit Do sNom = sNom & "," & VBA.Trim(end1.Offset(, 1).Value) Else Exit Do End If Loop End If If sNom <> "" Then .Range("F" & i + 2).Value = VBA.Mid(sNom, 2) sNom = "" End If Next i End With End Sub .

Experimente assim:

@Aron Gerd Ristow Filho eu nao conheco uma forma de tornar padrão essas referenicas. o que voce pode fazer e "marcar" as referencias programaticamente. aqui tem um link com exemplo. How to change the default vba references in excel 2010 Mas eu particularmente nao gosto trabalhar com as referencias, pois quando voce roda uma macro em uma versao diferente do Excel apresenta erros, por exemplo marca a referencia no excel 14.0 e vai rodar no Excel 15.0. Eu prefiro criar o objeto, fazer as operacoes, em seguida destruir. Ex. Dim adoconexao As Object Dim rsincluir As Object Dim adOpenKeyset: adOpenKeyset = 1 Dim adLockOptimistic: adLockOptimistic = 3 Set adoconexao = VBA.CreateObject("ADODB.Connection") Set rsincluir = VBA.CreateObject("ADODB.Recordset") ---------------------------------------- rsincluir.Open planilha, adoconexao, adOpenKeyset, adLockOptimistic ---------------------------------------- ---------------------------------------- ---------------------------------------- Set adoconexao = Nothing Set rsincluir = Nothing * Desta forma nao apresenta erros de incompatibilidade * E neste caso de conectar com o access nenhuma referencia de biblioteca é neccessária ser marcada.

Por default o banco de dados access não aceita registro nulos, a conversão é justamente para não gerar erros.

@Charley Rochaconverte o intervalo de células vazias em string. @Aron Gerd Ristow Filho experimente rsincluir.Open planilha, adoconexao, adOpenKeyset, adLockOptimistic

@Izabela1992 substitue no código o numero 4 por ThisWorkbook.Worksheets.Count

Neste objeto shape não tem esse recurso. Pode usar o objeto image activeX, adaptando o código de exemplo

Pode fazer desta forma: VBA.Left(SuaImagem.png, VBA.InStr(SuaImagem.png, ".") - 1)

@Luan Teles desculpe, mas não entendi. No seu arquivo(exemplo) , não vi formula e está funcionando perfeitamente!

Veja se é isso que deseja: Option Explicit Sub GetFileNames() Dim rowB As Long: rowB = 2 Dim rowC As Long: rowC = 3 Dim xDirect, xFname, InitialFoldr InitialFoldr = "C:\" With Excel.Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = Excel.Application.DefaultFilePath & "\" .Title = " Selecione o Aquivo " .InitialFileName = InitialFoldr .Show If .SelectedItems.Count <> 0 Then xDirect = .SelectedItems(1) & "\" xFname = VBA.Dir(xDirect, 7) Do While xFname <> "" Range("B" & rowB) = xFname Range("C" & rowC) = xDirect rowB = rowB + 1 rowC = rowC + 1 xFname = VBA.Dir Loop End If End With End Sub

Sem usar Api, uma opcao é atraves de Excel, exemplo: Sub Salvar_PrintScr_como_Png() Dim objGraf As Chart Dim paint Set objGraf = Charts.Add objGraf.Paste objGraf.Export Filename:=ThisWorkbook.Path & "\PrintScnSalvo.png", Filtername:="PNG" Excel.Windows.Application.DisplayAlerts = False objGraf.Delete Excel.Windows.Application.DisplayAlerts = True 'abre o arquivo png paint = VBA.Shell("c:\windows\system32\mspaint.exe " & ThisWorkbook.Path & "\PrintScnSalvo.png", vbMaximizedFocus) End Sub

@Flávia de Oliveira Batista qual o critério de comparacão ?

@Luan Teles veja este exemplo de busca avancada que pesquisa em todas as colunas com dados. Controle de Processos.zip

Utilizando o seu arquivo como exemplo, acrescentei no assunto, o nome da empresa e o anexo* Quanto a assinatura voce pode personalizar a sua assinatura no próprio Outlook ou ver as dicas neste link: https://www.rondebruin.nl/win/s1/outlook/signature.htm * Altere o caminho (diretorio), se necessário e NOME E EXTENSAO DO ARQUIVO que sera enviado. PLANILHA 01_Envia_E-mail_1.zip

@Car36 veja se este exemplo:

Segue sugestào em vba. Cole o codigo abaixo no modulo da respectiva aba. Ao digitar um numero de cpf na coluna A a macro verifica e converte no formato CPF. Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 1 Or _ Target.Count > 1 Then Exit Sub Target.NumberFormat = "General" Target.Interior.ColorIndex = xlNone numCPF = Target.Value numCPF = VBA.Replace(numCPF, ".", "") numCPF = VBA.Replace(numCPF, "-", "") If VBA.Val(numCPF) = 0 Or validaCPF(numCPF) <> "OK" Then Target.Interior.ColorIndex = 3 Exit Sub Else Target.Value = VBA.Left(numCPF, 3) & "." & _ VBA.Mid(numCPF, 4, 3) & "." & _ VBA.Mid(numCPF, 7, 3) & "-" & _ VBA.Right(numCPF, 2) End If End Sub E em um modulo padrão, a funcao que verifica se o cpf é valido. Function validaCPF(numCPF) If VBA.Len(numCPF) < 11 Then numCPF = VBA.String(11 - VBA.Len(numCPF), "0") & numCPF For caracter = 1 To 9 DV1 = VBA.Val(Vba.Mid(numCPF, caracter, 1)) * caracter + DV1 If caracter > 1 Then DV2 = VBA.Val(Mid(numCPF, caracter, 1)) * (caracter - 1) + DV2 Next DV1 = VBA.Right(DV1 Mod 11, 1) DV2 = VBA.Right((DV2 + (DV1 * 9)) Mod 11, 1) If VBA.Mid(numCPF, 10, 1) = DV1 And VBA.Mid(numCPF, 11, 1) = DV2 Then validaCPF = "OK" End Function fonte da funcao valida...: http://twixar.me/tPbT

@DavidsonGomes1998 veja se é isso Private Sub Btn_Preencher_Click() Dim List As ListItem Dim sql As String ConectDB On Error GoTo trat_err sql = "SELECT [CodProduto],[Produto], SUM([Quant]) AS tl_Quant, SUM([SubTotal]) AS tl_SubTotal " sql = sql & "FROM [tb_venda_p] " sql = sql & "WHERE [Quant] IS NOT NULL " sql = sql & "GROUP BY [CodProduto],[Produto];" rs.Open sql, db, 3, 3 Me.ListView1.ListItems.Clear While Not rs.EOF Set List = Me.ListView1.ListItems.Add(Text:=rs!CodProduto) List.SubItems(1) = rs!Produto List.SubItems(2) = rs!tl_Quant List.SubItems(3) = VBA.Format(rs!tl_SubTotal, "#,##0.00") rs.MoveNext Wend trat_err: FechaDb End Sub

Para que sua demanda seja atendida, sugiro que disponibilize exemplo da sua planilha e do banco de dados com alguns dados fictícios.

@Daniela.Dias segue sugestao de envio em massa pelo outlook. Na coluna D insira os enderecos de e-mails validos, dos prestadores. E na celula F1 altere o texto do assunto do e-mail. PLANILHA 01_Envia_E-mail.zip

@Luan Teles fiz as adaptacões no código conforme seu arquivo, veja se é isso.. No arredondamento da temperatura alterei para para cima, anteriormente estava para baixo. No Excel tem dessas coisas ! E nem Bill Gates explica Bom mas eu contornei essa inconsistência, colocando uma rotina para posicionar corretamente de forma automática: * No modulo da sua aba "Resumo Geral"`, cole o código abaixo. E ai quando você ativar essa aba novamente, a macro vai corrigir esse problema. Private Sub Worksheet_Activate() On Error Resume Next With ActiveSheet.Shapes("Icone_Tempo") .Width = [Q2:P2].Width .Height = [P1:Q8].Height .Top = Rows([O1].Row).Top .Left = Columns([P2].Column).Left End With On Error GoTo 0 End Sub .

@Migguds sim eu alterei para "puilar" linha para este caso. Public Sub LeArquivoTexto() Dim Arquivo As Integer Dim CaminhoArquivo As String Dim TextoProximaLinha As String Dim ContadorLinha As Long 'Configura a leitura do arquivo Arquivo = FreeFile CaminhoArquivo = ThisWorkbook.Path & "\relação.ini" ' "C:\Users\CAIO\Desktop\relação.ini" 'Abre o arquivo para leitura Open CaminhoArquivo For Input As Arquivo ContadorLinha = 1 'Lê o conteúdo do arquivo linha a linha With ActiveSheet Do While Not EOF(Arquivo) Line Input #Arquivo, TextoProximaLinha If VBA.InStr(TextoProximaLinha, "[") = 0 Then If VBA.Right(TextoProximaLinha, (VBA.Len(TextoProximaLinha) - _ VBA.InStr(TextoProximaLinha, "="))) <> "" Then .Cells(ContadorLinha, "F") = VBA.Right(TextoProximaLinha, (VBA.Len(TextoProximaLinha) - _ VBA.InStr(TextoProximaLinha, "="))) ContadorLinha = ContadorLinha + 1 Else ContadorLinha = ContadorLinha + 1 End If End If Loop End With 'Fecha o arquivo Close Arquivo End Sub

@Luan Teles Sim ficou bem melhor agora, ainda mais quando tiver... "Só Jesus na Causa" Já incluir nas alteracoes.!!! não tinha me observado. que a api aceitava acentos. valeu Alterei para o provedor de localização, que você indicou Quanto a imagem( icone ), no ambiente Excel, vb, vba nao da pra fazer como no ambiente html ajustar a "temperatura". Mas tem algumas opções de efeito na forma (shape), entao eu acrescentei brilhos ao redor da imagem que acaba realcando, veja os resultados: ... Codigo Atualizado:

Esta aparecendo esta mensagem ao tentar abrir sua planilha:

@Douglas ianes fiz o teste e aqui para mim esta funcionando certinho como eu disse, sem ver o seu arquivo (planilha) ou um exemplo, fica difícil dar um parecer exato. De qualquer forma, no modo "achômetro" verifique se colou a funcao GoogleTranslate em um modulo padrão