Basole

Outra sugestao e usar o select case para selecionar um caminho de acordo com o usuario da maquina: Exemplo: Dim strPath As String Select Case Environ("USERPROFILE") Case "C:\Users\Zé" strPath = "C:\PROPOSAL_SCOPE\ENG\" Case "C:\Users\Mané" strPath = "C:\PROPOSAL_SCOPE\ENG\Mané" 'Case ......... '................. End Select

Envie um exemplo do arquivo para entender melhor o cenário e a estrutura dos dados.

Sem ver os arquivos nao da pra dar um parecer com exatidao. De qualquer forma experimente "setar" o arquivo: Gráfico - Custo Diário.xlsx e abrir (caso esteja fechado), em seguida ativa-lo Exemplo: Dim wb As Workbook Set wb = Excel.Workbooks.Open(Diret & "\Gráfico - Custo Diário.xlsx") wb.Activate

Talvez se pudesse alterar a estrutura do diretorio e referenciasse um caminho a partir do usuario da maquina, atraves da funcao Environ nao precisaria fazer a alteracoes citadas para para usuario Exemplo: Environ("USERPROFILE") \Documents\SUA_PASTA => C:\USERS\Nome_do_Usuario\Meus Documentos\SUA_PASTA Mais detalhes: Obtendo nome de usuário, pastas especiais e muito mais usando a função Environ E para o MAC Obter o usuario da maquina no OSX

@DaviCN infelizmente no exemplo do link que mostrei não prevê quantidade maior para itens/linhas do listbox que sao mostrados na tela. Ou seja como a selecao e atraves do movimento do mouse, o pop-up,só mostra os 20 primeiros itens/linhas do listbox que estão na tela no limite x e y. Vou ver se consigo driblar essa limitacão sem o uso de api, e posto aqui. Segue em anexo o arquivo: SISTEMA IDEO_Atualiz.zip

@DaviCN sem ver o seu arquivo nao da pra responder com exatidao, mas acredito que tenha esquecido de nomear corretamente o userForm. Se for isso, pode alterar a linha desta forma: If Position < Me.Lst_Busca.ListCount And Position >= 0 Then E para o pop-up se ajustar ao texto, experimente ajustar no codigo a largura: .Width = VBA.Len(Me.Lst_Busca.List(Position)) * 8 Acrescente tambem, para o pop-up "sumir" quando o ponteiro do mouse NAO estiver selecionando um item do listbox: Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Controls("TIPTEXT").Visible = True Then Controls("TIPTEXT").Visible = False End Sub

Veja se e isso que precisa Usei colunas auxiliares na aba base Base Temporários.xls

Veja esta solucao, talvez possa lhe ajudar. Update ControlTipText for a listbox before displaying it

@deku221 se está lendo os códigos de barras pelo celular, não vai conseguir inserir no TextBox pois este componente só roda através do VBA e o VBA não roda no ambiente móbile.

@marcelo costa Jr apenas vinculado. Segue os arquivos ajustados a funcao Para retornar o motorista use =PROCV_ACCESS(Celula;FALSO);e para retornar o CPF PROCV_ACCESS(Celula;VERDADEIRO) Segue os arquivos, e o BD com os dados importados: https://1drv.ms/u/s!AklQQunG_lmmg0sXEdNheA2Ugyjt?e=ncrJl9

@marcelo costa Jr sua tabela Dados.xlsx esta vinculada ao banco de dados BD_placas.accdb sendo assim nao tenho como acessar os dados. Disponibilize o arquivo Dados.xlsx para eu tentar importar para o access.

@marcelo costa Jr voce precisa compartilhar publicamente seus arquivos para qualquer pessoa possa ter acesso

@marcelo costa Jr Nao sei o que significa campo CAVALO, pois na imagem nao vi nada relacionado. Eu postei um exemplo simples de consulta ao banco access, mas se pretende adaptar a sua planilha, seu cenário, preciso que disponibilize exemplos dos seus arquivos para tentarmos adaptar a sua situacao, pois o exemplo de codigo generico, nao atende a todas as demandas. De quaquer forma ajustei o codigo a uma funcao (udf) * Para testar cole o codigo abaixo em um modulo e em qualquer célula coloque, por exemplo =PROCV_ACCESS(A1) Function PROCV_ACCESS(rng As Range) As String Dim sql As String Dim db As Object Dim rs As Object Dim Path As String Dim s_Placa As String Set db = VBA.CreateObject("ADODB.Connection") Set rs = VBA.CreateObject("ADODB.Recordset") Path = "C:\Users\luizjunior\Documents\BD_placas.accdb" s_Placa = rng.Value2 db.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Path & ";" On Error GoTo trat_err sql = "SELECT * " sql = sql & "FROM [Dados] " sql = sql & "WHERE [PLACA]='" & s_Placa & "'" rs.Open sql, db, 3, 3 While Not rs.EOF PROCV_ACCESS = rs![MOTORISTA] & "; " & _ rs![C#P#F# motorista] rs.MoveNext Wend trat_err: db.Close: Set db = Nothing Set rs = Nothing End Function

@marcelo costa Jr de acordo com a imagem do seu banco de dados access, fica desta forma a consulta: Sub PROCV_IN_TABELA_ACCESS() Dim sql As String Dim db As Object Dim rs As Object Dim Path As String Dim s_Placa As String Set db = VBA.CreateObject("ADODB.Connection") Set rs = VBA.CreateObject("ADODB.Recordset") Path = "C:\Users\luizjunior\Documents\BD_placas.accdb" s_Placa = "DADOS DA PLACA" '* ou a celula que contem a placa db.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Path & ";" On Error GoTo trat_err sql = "SELECT * " sql = sql & "FROM [Dados] " sql = sql & "WHERE [PLACA]='" & s_Placa & "'" rs.Open sql, db, 3, 3 While Not rs.EOF MsgBox rs![MOTORISTA] & VBA.vbNewLine & _ rs![C#P#F# motorista] rs.MoveNext Wend trat_err: db.Close: Set db = Nothing Set rs = Nothing End Sub

@marcelo costa Jr voce tem que alterar no codigo, os nomes dos campos, de acordo com os nomes dos campos da tabela do access. * Se tiver dificuldades, anexe seus arquivos ou exemplos aqui.!

@marcelo costa Jr segue exemplo basico de busca de dados dentro de banco de dados access Sub PROCV_IN_TABELA_ACCESS() Dim sql As String Dim db As Object Dim rs As Object Dim Path As String Dim s_Placa As String Set db = VBA.CreateObject("ADODB.Connection") Set rs = VBA.CreateObject("ADODB.Recordset") Path = ThisWorkbook.Path & "\AQUI NOME DO BANCO DE DADOS ACCESS E A EXTENSAO" s_Placa = "Aqui_dados_da_Placa" 'ou a celula que contem a placa db.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Path & ";" On Error GoTo trat_err sql = "SELECT * " sql = sql & "FROM [NOME_DA_SUA_TABELA] " sql = sql & "WHERE [CAMPO_PLACA]='" & s_Placa & "'" rs.Open sql, db, 3, 3 While Not rs.EOF MsgBox rs![NOME DO CAMPO MOTORISTA] & VBA.vbNewLine & _ rs![NOME DO CAMPO CPF] rs.MoveNext Wend trat_err: db.Close: Set db = Nothing Set rs = Nothing End Sub * OBS: Alteracoes que devem ser feitas no codigo de acordo com os seus dados: Path = ThisWorkbook.Path & "\AQUI NOME DO BANCO DE DADOS ACCESS E A EXTENSAO" * coloque o endereco do seu banco, nome e extensao Altere de acordo com os dados da tabela do access: [NOME_DA_SUA_TABELA], [CAMPO_PLACA], [NOME DO CAMPO MOTORISTA], [NOME DO CAMPO CPF]

@Janilson Brito experimente: Em modo SQL... SELECT [Sua_Tabela].[nome da maquina] , GetList("Select Scripts From [Sua_Tabela] As T1 WHERE Scripts LIKE '[0-9]%' AND T1.[nome da maquina] = """ & [Sua_Tabela].[nome da maquina] & """","","; ") AS _Scripts, COUNT(Scripts) AS [Total de Scritps] FROM [Sua_Tabela] WHERE Scripts LIKE '[0-9]*' GROUP BY [Sua_Tabela].[nome da maquina]; * Substituindo acima, Sua_Tabela pelo nome da sua tabela.

Outra opcão de consulta, concatenando os resultados do scripts no campo scripts atraves de uma funcao SELECT [Sua_Tabela].[nome da maquina] , GetList("Select Scripts From [Sua_Tabela] As T1 Where T1.[nome da maquina] = """ & [Sua_Tabela].[nome da maquina] & """","",", ") AS _Scripts, COUNT(*) AS [Total de Scritps] FROM [Sua_Tabela] GROUP BY [Sua_Tabela].[nome da maquina]; * Substitua acima, Sua_Tabela pelo nome da sua tabela. Quanto a funcao, crie um modulo no access e cole o codigo abaixo: Public Function GetList(SQL As String _ , Optional ColumnDelimeter As String = ", " _ , Optional RowDelimeter As String = vbCrLf) As String Const PROCNAME = "GetList" Const adClipString = 2 Dim oConn As Object Dim oRS As Object Dim sResult As String On Error GoTo ProcErr Set oConn = CurrentProject.Connection Set oRS = oConn.Execute(SQL) sResult = oRS.GetString(adClipString, -1, ColumnDelimeter, RowDelimeter) If Right(sResult, Len(RowDelimeter)) = RowDelimeter Then sResult = Mid$(sResult, 1, Len(sResult) - Len(RowDelimeter)) End If GetList = sResult oRS.Close oConn.Close CleanUp: Set oRS = Nothing Set oConn = Nothing Exit Function ProcErr: ' insert error handler Resume CleanUp End Function

Sem os outros arquivos envolvidos nao tem como testar e tentar lhe ajudar na questào do formato da numeracao: nnddmmaa Para incrementar a autonumeracão, ou seja executar a macro somente quando salvar o arquivo, coloque o codigo abaixo no modulo ThisDocument. Private WithEvents App As Word.Application Private Sub Document_Open() Set App = Word.Application End Sub Private Sub App_DocumentBeforeSave(ByVal Doc As Document, SaveAsUI As Boolean, Cancel As Boolean) Call Cartanumerada End Sub

@Alexandreudi disponibilize os arquivos ou exemplos próximos do original.

Considerando o cenario, grupo 1 de numeros a partir da celula A2 e o grupo 2 a partir da celula B2, em C2 coloque a formula abaixo e arraste.para baixo =SEERRO(PROCV(B2;$A$2:$A$30;1;0);"")

@Luan Teles altere a linha abaixo no código: .[M2] = xmlresponse.SelectNodes("//current/city/@name")(0).Text ...por esta: .[M2] = cidLoc ..ou se preferir sem o BR: .[M2] = VBA.Left(cidLoc, VBA.InStr(cidLoc, ",") - 1)

@Maíra Souza Lima anexe aqui o seu exemplo, pois o codigo exemplo postado, nao atende de forma gernerica, e sim caso a caso

@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 .