Basole

@Douglas ianes nao sei se vou conseguir lhe ajudar pontualmente, sem analisar o seu cenário, enderecos das células, formatacões, etc. De qualquer estou enviando um exemplo generico para voce adaptar: * Considerando que o texto em portugues esteja na PLAN1, celula A2 O resultado da consulta aparecerá na PLAN2, na celula A2 No modulo da sua PLAN1. cole o código abaixo: Private Sub Worksheet_Change(ByVal Target As Range) If Not Excel.Application.Intersect(Target, Range("A2:A10")) Is Nothing Then Sheets("Plan2").Range("A2").Value2 = GoogleTranslate(Target.Value2, "en") End If End Sub E no modulo padrão, cole a funcao que consulta no Google tranlate: Function GoogleTranslate(InputText As String, ToLang As String) As String Dim IE As Object Set IE = CreateObject("InternetExplorer.application") IE.Visible = False IE.navigate "http://translate.google.com/#auto/" & ToLang & "/" & InputText Do Until IE.ReadyState = 4 DoEvents Loop Application.Wait (Now + TimeValue("0:00:5")) Do Until IE.ReadyState = 4 DoEvents Loop GoogleTranslate = IE.Document.getElementsByClassName("result-shield-container tlid-copy-target")(0).innertext IE.Quit End Function * Lembrando que existe um delay entre uma consulta e outra isso pode gerar lentidao ou erro dependendo da qtd de consultas por minuto.

Segue sugestao: Na page1 selecionando um item no listbox1 o mesmo item do listbox2, tambem é selecionado. Private Sub ListBox1_Click() Dim i As Long For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) = True Then ListBox2.Selected(i) = True Exit For End If Next i End Sub Na Page2 idem, tambem caso selecione um item (listbox2), no listbox1 o item sera selecionado. Private Sub ListBox2_Click() Dim i As Long For i = 0 To ListBox2.ListCount - 1 If ListBox2.Selected(i) = True Then ListBox1.Selected(i) = True Exit For End If Next i End Sub Dicas: 1- Não uttilize o evento Change do listbox,e sim o Exit, pois nesse caso entra em loop. 2- a Propriedade RowSource deixa o listbox literamente amarrada aos dados da planilha, ai quando que usar a propriedade .Clear, para limpar os dados gera um erro. Quando se usa RowSOurce, ou voce limpa os dados da planilha, ou desvindula o RowSource = "" ai voce pode limpar os dados atraves do clear. Para carregar dados voce pode utilizar a propriedade List. Segue exemplo: Private Sub UserForm_Initialize() Me.MultiPage1.Value = 0 Dim LR As Long Dim rngArr As Variant With ThisWorkbook.Sheets("Vendas") .AutoFilterMode = False LR = .Cells(.Rows.Count, 1).End(xlUp).Row rngArr = .Range("A2:G" & LR).Value Me.ListBox1.RowSource = "" Me.ListBox1.List = rngArr End With End Sub

@Migguds se o resutado desejado é esse (imagem) , segue seu codigo com as alteracoes: 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 = "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 .[F1:F14].ClearContents Do While Not EOF(Arquivo) Line Input #Arquivo, TextoProximaLinha If VBA.InStr(TextoProximaLinha, "[") = 0 Then .Cells(ContadorLinha, "F") = VBA.Right(TextoProximaLinha, (VBA.Len(TextoProximaLinha) - _ VBA.InStr(TextoProximaLinha, "="))) ContadorLinha = ContadorLinha + 1 End If Loop End With 'Fecha o arquivo Close Arquivo End Sub

@Francyne deve estar derretendo ai em campinas com 28 graus neste momento Nao sei o que pode estar ocorrendo, pois pra mim e para o @Luan Teles a geo-localizacao,está funcionando certinho. Bom, mas eu fiz uma alteracao no codigo e agora como alternativa, a macro pergunta em qual cidade se encontra Para isso deixa a celula A2 em branco (vazia). Para a macro buscar a respectiva localizacao automaticamente, clck no botao cancelar na janela que solicita a cidade. @Luan Teles nao detectei nenhuma alteracao na UR da imagem (icone), o que acontece e que só tem disponivel,, pelo que percebi 4 imagens diferentes: openweathermap.org/img/wn/[email protected] entao quando esta como "overcast clouds" aparece o mesmo icone de "broken clouds" Eu fiz algumas alteracoes pois percebi que estava inconsitentes e pelos testes que fiz agora esta atualizando tudo ok. . Previsao Tempo_V2.zip

Segue exemplo em vba no access Dim dtIni As Date Dim dtFin As Date Dim j As Long Dim findEvent As Variant Const sDesc As String = "Férias,Licença saúde,Folgas,etc" ' Altere/Acresc. os eventos dtIni = VBA.Format("01/20/2019", "mm/dd/yyyy") '* altere as suas datas dtFin = VBA.Format("01/23/2019", "mm/dd/yyyy") findEvent = VBA.Split(sDesc, ",") DoCmd.SetWarnings False For j = 0 To UBound(findEvent) DoCmd.RunSQL "INSERT INTO tblAusencias([DT],[Descrição]) VALUES " & _ "(#" & VBA.Format(dtIni, "mm/dd/yyyy") & "#,'" & findEvent(j) & "')" dtIni = dtIni + 1 Next j DoCmd.SetWarnings True MsgBox j + 1 & " resgistros Salvos", 64, "Sucesso"

Veja se atende: Dim mDataObj As Object Dim strCopy As String Set mDataObj = VBA.CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") mDataObj.GetFromClipboard If mDataObj.GetFormat(1) = True Then strCopy = mDataObj.GetText mDataObj.SetText strCopy mDataObj.PutInClipboard Sheets("COLAR_PLATAFORMA").Select Range("B2").Select ActiveSheet.Paste Else MsgBox "erro solicitando ao usuário que copie os dados da fonte", _ vbCritical, "Aviso!!" End If Set mDataObj = Nothing

@Nadjala no formulario 2 e no botao salvar, voce tinha 8 imagens se nao me engano? Se for isso, coloque esta verificacao que checa se a imagem esta presentes nos controles de imagens activeX do userform2 Dim ftn As Integer For ftn = 1 To 8 If Me.Controls("Image" & ftn).Picture Is Nothing Then MsgBox "Insira a Foto " & ftn & " para continuar!", vbCritical, "Atencao" Exit Sub End If Next Ou se preferir que na mensagem apareca o nome ou a referencia da imagem, no evento userform Initialize "carrege" na propriedade .Tag das imagens activex a referencia, ex.: Image1.tag = "Horas de Funcionamento" e assim para os outros controles. e utilize esta verificacao: Dim ct As Control For Each ct In Me.Controls If TypeName(ct) = "Image" Then If ct.Picture Is Nothing Then MsgBox "Insira a Foto " & ct.Tag & " para continuar!", vbCritical, "Atencao" Exit Sub End If End If Next

Experimente: IE.Document.forms(0).submit

Acrescentei agora esta comando para deletar a imagem nomeada como Icone_Tempo e ao inserir a imagem renomea desta forma. codigo:

@Luan Teles como no PC nao vem com app de localizacao nativa, utilizei a api para localizar o ip externo e obter a cidade e pais, assim nao precisa mais informar a cidade. Pelo que pesquisei TheWeatherChanel e AccuWeather tem api pagos. Adicionei a Unidade de Medida junto ao valor da Temperatura °C (graus ceucius) Traduzindo few clouds, clear sky, overcast clouds, scattered clouds, etc nao ida dar muito certo pois o google translate, traduz ao pé da letra. Entao associei os termos em inglês, ao em portugues. E tambem acrescentei % a umidade. Ah..e tambem traz o icone (imagem), de acordo com o tempo. Sub Obtendo_a_Previsao_c_Localizacao() Dim xmlhttp As Object Dim url As String Dim xmlresponse As Object Dim FinHTTP As Object Dim cidLoc As String Dim FinCloudIn() As String Dim FinCloudOut() As String Dim outarr() As String Dim x As Integer Dim j As Integer Dim mPicture As Picture Dim ws As Worksheet Const sCloudIn As String = "clear sky,few clouds,scattered clouds, broken clouds,overcast clouds" Const sCloudOut As String = "Céu Limpo,Poucas Nuves,Nuvens Dispersas,Céu Encoberto,Nublado" Set FinHTTP = VBA.CreateObject("Microsoft.xmlHTTP") Set xmlhttp = VBA.CreateObject("MSXML2.serverXMLHTTP") ' Set xmlresponse = VBA.CreateObject("MSXML2.DOMDocument.6.0") Set ws = ThisWorkbook.Sheets(1) ' PLan 1 With ws url = "http://extreme-ip-lookup.com/csv/" FinHTTP.Open "GET", url, False FinHTTP.send FinCloudIn = Split(FinHTTP.responseText, ",") ReDim outarr(UBound(FinCloudIn) - 1) For j = 0 To UBound(FinCloudIn) - 1 outarr(j) = FinCloudIn(j) Next j cidLoc = VBA.Replace(outarr(10), """", "") & "," & _ outarr(7) url = "http://api.openweathermap.org/data/2.5/weather?apikey=4a2360d14bf33378079d2e2d49e35ddb&mode=xml&units=metric&q=" & _ cidLoc xmlhttp.Open "GET", url, False xmlhttp.send xmlresponse.LoadXML (xmlhttp.responseText) FinCloudIn = VBA.Split(sCloudIn, ",") FinCloudOut = VBA.Split(sCloudOut, ",") For j = 0 To UBound(FinCloudIn) If FinCloudIn(j) = xmlresponse.SelectNodes("//current/clouds/@name")(0).Text Then x = j Exit For End If Next j .[A2:C8].ClearContents On Error Resume Next .[A2] = xmlresponse.SelectNodes("//current/city/@name")(0).Text .[B2] = "Temperatura:": .[B3] = "Minima:": .[B4] = "Maxima: ": .[B5] = "Umidade: " .[B6] = "Céu:": .[B7] = "Vento:": .[B8] = "Última Atualização" .[C2] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//current/temperature/@value")(0).Text), 0) & VBA.Chr(176) & _ VBA.UCase(VBA.Left(xmlresponse.SelectNodes("//current/temperature/@unit")(0).Text, 1)) .[C3] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//current/temperature/@min")(0).Text), 0) & VBA.Chr(176) & _ VBA.UCase(VBA.Left(xmlresponse.SelectNodes("//current/temperature/@unit")(0).Text, 1)) .[C4] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//current/temperature/@max")(0).Text), 0) & VBA.Chr(176) & _ VBA.UCase(VBA.Left(xmlresponse.SelectNodes("//current/temperature/@unit")(0).Text, 1)) .[C5] = xmlresponse.SelectNodes("//current/humidity/@value")(0).Text & xmlresponse.SelectNodes("//current/humidity/@unit")(0).Text .[C6] = FinCloudOut(x) .[C7] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//wind/speed/@value")(0).Text) / 1000 * 3600, 0) & " Km/h" .[C8] = VBA.Replace(xmlresponse.SelectNodes("//current/lastupdate/@value")(0).Text, "T", " ") .[C8] = .[C8] - VBA.TimeSerial(3, 0, 0) x = VBA.IIf(FinCloudOut(x) = "Nublado", 3, x) 'Insere o icone do Tempo: Set mPicture = .Pictures.Insert("https://openweathermap.org/img/wn/0" & x + 1 & "[email protected]") With mPicture .ShapeRange.LockAspectRatio = msoFalse '.Width = ws.[D3].Width '.Height = ws.[D3].Height .Top = Rows(ws.[D3].Row).Top .Left = Columns(ws.[D3].Column).Left End With On Error GoTo 0 End With End Sub

Experimente Cells.Replace What:="xx/xx/19", Replacement:=VBA.Format(Application.Cells(1, 1), "dd/mm/yy"), LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False

Verifique se o seu campo CodPlanoVenda está armazenado como string, altere na consulta inserindo aspas simples no critério: ex.: '1'

@Luc Rosenhaim corrija as linhas abaixo: CPF = Range("c" & linha).Value Codigo = Range("f" & linha).Value IE.document.all("NI").Value = CPF

@DavidsonGomes1998 a Dsoma funciona no access ou com a biblioteca. No caso do seu ultimo exemplo, o filtro pode ser feito na própria consulta, sem a necessidade de usar o select case: Dim Soma_Dh As Double ConectDB On Error GoTo trat_Erro rs.Open "SELECT * FROM [tb_fluxo] WHERE [CodPlanoVenda]=1 AND [Natureza]='D'", db, 3, 3 While Not rs.EOF Soma_Dh = Soma_Dh + rs!valor.Value rs.MoveNext Wend Lbl_Saldo_DinheiroCaixa = Soma_Dh trat_Erro: FechaDb If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description On Error GoTo 0

@DavidsonGomes1998 se quer inserir os dados juntamente com o carregamento do ListView, Eu faria assim, usando o select case: Declarando as variaveis: 'DESPESAS Dim SomaDh_D As Double Dim SomaDe_D As Double Dim SomaCr_D As Double Dim SomaCHA_D As Double Dim SomaCHP_D As Double Dim SomaBa_D As Double Dentro do while: 'DESPESAS Select Case rs!CodPlanoVenda & rs!Natureza Case Is = "dinheiro" & "D" SomaDh_D = SomaDh_D + rs!Valor.Value Case Is = "DINHEIRO" & "D" SomaDh_D = SomaDh_D + rs!Valor.Value Case Is = "CARTÃO DÉBIT.." & "D" SomaDe_D = SomaDe_D + rs!Valor.Value Case Is = "BANCO" & "D" SomaBa_D = SomaBa_D + rs!Valor.Value ' Continue... abaixo... ' SomaCr_D ' SomaCHP_D ' SomaCHA_D End Select Depois associe cada variavel aos respectivos campos (textbox (s)) As Receitas deixo por sua conta, é so sequir a lógica

Uma opcao é importar os dados online, para um arquivo Excel atraves do vba, e vincular a apresentacao Powerpoint ao arquivo. Exemplo: * Na Plan1, celula A2, insira o nome da cidade e a sigla do pais, ex. sao paulo,br ( sem acentos ) Sub Obtendo_a_Previsao() Dim xmlhttp As Object Dim url As String Dim xmlresponse As Object Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP") ' Set xmlresponse = CreateObject("MSXML2.DOMDocument.6.0") With ThisWorkbook.Sheets(1) url = "http://api.openweathermap.org/data/2.5/weather?apikey=4a2360d14bf33378079d2e2d49e35ddb&mode=xml&units=metric&q=" & _ VBA.Replace(.Range("A2").Value, " ", "%20") xmlhttp.Open "GET", url, False xmlhttp.Send xmlresponse.LoadXML (xmlhttp.responseText) .[B2:C4].ClearContents On Error Resume Next .[B2] = "Minima:": .[B3] = "Maxima: ": .[B4] = "Umidade: " .[C2] = xmlresponse.SelectNodes("//current/temperature/@min")(0).Text .[C3] = xmlresponse.SelectNodes("//current/temperature/@max")(0).Text .[C4] = xmlresponse.SelectNodes("//current/humidity/@value")(0).Text On Error GoTo 0 End With End Sub

Só com a imagem do seu userform e componentes, fica difícil dar um parecer exato. De qualquer forma, experimente acrescentar o caractere % após aspas simples, para pesquisar, no campo todo . rs.Open "Select * from tb_clientes where Nome like '%" & CLIENTE & "'%", db, 3, 3

Experimente acrescentar na sua macro: With ActiveSheet.PageSetup .Order = xlOverThenDown '<~~ Frente verso End With

@nnunoo acho difícil alguém atender sua demanda, sem saber exatamente o que deseja. Nem o outro fórum responderam! Talvez alguém com uma bola de cristal ... Sugiro, que prepare um arquivo exemplo demostrando manualmente o resultado final, desejado.

voce pode usar o evento workbook_sheetchange, ex.: Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) If Sh.Name = "MUNDOS" Then If Target.Address = "$C$1" Then Call SuaMacro_1 End If End If If Sh.Name = "RESPAWS" Then If Target.Address = "$A$1" Then Call SuaMacro_2 End If End If End Sub E os eventos CommandButton1_Click e CommandButton2_Click, crie Sub(s) diferentes e coloque em um modulo padrão, ex.: SuaMacro_1 e SuaMacro_2 * Cole o evento Workbook_SheetChange em EstaPasta_de_trabalho:

Considerando que os dados armazenados na combobox cep, como valores,experimente sem as aspas simples. rs.Open "Select * FROM [tb_cep] WHERE [Codigo]=" & ComboBox_Cep.Text, db, 3, 3

Coloque a instrucão no evento _Click da Combobox CEP, para acionar automaticamente ConectDB rs.Open "Select * FROM [tb_cep] WHERE [Codigo]='" & "NOME_DO_SEU_COMBOBOX_C/A PROPRIED .Text(*sem as aspas) " & "'", db, 3, 3 If Not rs.EOF And Not rs.BOF Then ' * Altere abaixo o nome da textbox CIDADE e Combobox UF Me.textbox1.Text = rs.Fields(4).Value Me.combobox1.Text = rs.Fields(5).Value Else MsgBox "Registro Não Encontrado" End If FechaDb

Sim, caso também deseja automatizar esse processo, Fiz um exemplo de automacão, que faz uma varredura linha-a-linha da sheet1 e verifica se existe a aba com o nome do tipo de colaborador, caso an oexista, cria uma nova, renomeia e acrescenta o respectivo dado. Caso ja exista apenas insere o dado. Veja e é isso que deseja. teste_Automacao.zip

@nnunoo bom dia De uma forma geral deu pra entender, mas para tentar lhe ajudar é necessário detalhes mais específicos. Anexando exemplos de arquivos por exemplo, facilita o entendimento e ajuda a demonstrar o que pretende

@misterjohn experimente a macro abaixo: * cole em um modulo. Ao executar a macro, vai pedir para selecionar a pasta onde se encontra os arquivos " *.doc* a serem mesclados " Sub MergeDocuments() Application.ScreenUpdating = False Application.DisplayAlerts = wdAlertsNone Dim strFolder As String, strFile As String Dim DocSrc As Document, DocTgt As Document Dim strDocNm As String, Rng As Range, HdFt As HeaderFooter strFolder = GetFolder If strFolder = "" Then Exit Sub Set DocTgt = ActiveDocument strDocNm = DocTgt.FullName strFile = Dir(strFolder & "\*.doc") While strFile <> "" If strFolder & "\" & strFile <> strDocNm Then Set DocSrc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False) With DocTgt Set Rng = .Range.Characters.Last With Rng .Collapse wdCollapseEnd .InsertBreak Type:=wdSectionBreakNextPage .Collapse wdCollapseEnd Call LayoutTransfer(DocSrc, DocTgt) .FormattedText = DocSrc.Range.FormattedText End With For Each HdFt In .Sections.Last.Headers HdFt.LinkToPrevious = False HdFt.Range.Text = vbNullString Next For Each HdFt In .Sections.Last.Footers HdFt.LinkToPrevious = False HdFt.Range.Text = vbNullString Next For Each HdFt In .Sections(.Sections.Count - 1).Headers With HdFt.Range .FormattedText = DocSrc.Sections.Last.Headers(HdFt.Index).Range.FormattedText .Characters.Last.Delete End With Next For Each HdFt In .Sections(.Sections.Count - 1).Footers With HdFt.Range .FormattedText = DocSrc.Sections.Last.Footers(HdFt.Index).Range.FormattedText .Characters.Last.Delete End With Next End With DocSrc.Close False End If strFile = Dir() Wend Set Rng = Nothing: Set DocTgt = Nothing: Set DocSrc = Nothing Application.DisplayAlerts = wdAlertsAll Application.ScreenUpdating = True End Sub Sub LayoutTransfer(DocSrc As Document, DocTgt As Document) 'Document Body variables Dim sPageHght As Single, sPageWdth As Single Dim sHeaderDist As Single, sFooterDist As Single Dim sTMargin As Single, sBMargin As Single Dim sLMargin As Single, sRMargin As Single Dim sGutter As Single, sGutterPos As Single Dim lPaperSize As Long, lGutterStyle As Long Dim lMirrorMargins As Long, lVerticalAlignment As Long Dim lScnStart As Long, lScnDir As Long Dim lOddEvenHdFt As Long, lDiffFirstHdFt As Long Dim bTwoPagesOnOne As Boolean, bBkFldPrnt As Boolean Dim bBkFldPrnShts As Boolean, bBkFldRevPrnt As Boolean Dim bOrientation As Boolean 'Get Page Setup parameters With DocSrc.Sections.First.PageSetup lPaperSize = .PaperSize lGutterStyle = .GutterStyle bOrientation = .Orientation lMirrorMargins = .MirrorMargins lScnStart = .SectionStart lScnDir = .SectionDirection lOddEvenHdFt = .OddAndEvenPagesHeaderFooter lDiffFirstHdFt = .DifferentFirstPageHeaderFooter lVerticalAlignment = .VerticalAlignment sPageHght = .PageHeight sPageWdth = .PageWidth sTMargin = .TopMargin sBMargin = .BottomMargin sLMargin = .LeftMargin sRMargin = .RightMargin sGutter = .Gutter sGutterPos = .GutterPos sHeaderDist = .HeaderDistance sFooterDist = .FooterDistance bTwoPagesOnOne = .TwoPagesOnOne bBkFldPrnt = .BookFoldPrinting bBkFldPrnShts = .BookFoldPrintingSheets bBkFldRevPrnt = .BookFoldRevPrinting End With 'Set Page Setup parameters With DocTgt.Sections.Last.PageSetup .GutterStyle = lGutterStyle .MirrorMargins = lMirrorMargins .SectionStart = lScnStart .SectionDirection = lScnDir .OddAndEvenPagesHeaderFooter = lOddEvenHdFt .DifferentFirstPageHeaderFooter = lDiffFirstHdFt .VerticalAlignment = lVerticalAlignment .PageHeight = sPageHght .PageWidth = sPageWdth .TopMargin = sTMargin .BottomMargin = sBMargin .LeftMargin = sLMargin .RightMargin = sRMargin .Gutter = sGutter .GutterPos = sGutterPos .HeaderDistance = sHeaderDist .FooterDistance = sFooterDist .TwoPagesOnOne = bTwoPagesOnOne .BookFoldPrinting = bBkFldPrnt .BookFoldPrintingSheets = bBkFldPrnShts .BookFoldRevPrinting = bBkFldRevPrnt .PaperSize = lPaperSize .Orientation = bOrientation End With End Sub Function GetFolder() As String Dim oFolder As Object GetFolder = "" Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0) If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path Set oFolder = Nothing End Function * Fonte: https://tinyurl.com/uw676mf