COMPRADOR

Boa noite Tenho várias conexões no power query: RH RH_3 SiteInspector SiteInspectorUn Tabela1 Preciso que na consulta SiteInspector seja acrescentada uma coluna que traga a soma de unidades existentes na consulta SiteInspectorUn que correspondam ao endereço cadastrado em coluna na consulta siteInspector. Depois preciso de outra coluna que carregue uma regional existente em coluna na consulta Tabela1, correspondente a cidade existente em coluna na consulta SiteInspector. Como faço isto por fórmula no PowerQuery? sou nova e não estou conseguindo. Agradeço quem puder me dar uma luz.

Boa tarde Estou construindo um app no powerapps para servir como consulta de dados de diversas unidades. Normalmente a navegação entre telas se dá entre a escolha de uma listagem. Contudo preciso ao clicar em um ícone abrir outras tela com dados carregados do endereço selecionado que conta em cartão. Isto é possível? porque está dando erro e carregando errado. Obrigada

Bom dia Estamos migrando os arquivos da área para nuvem. Muitos não subiram por conter nomes longos demais. Estou querendo alterar estes nomes por comando bat usando ren ou move. Está dando erro e não sei porque. São diversos arquivos em diferentes diretórios e pastas. Queria uma fórmula que permitisse fazer de uma vez, estou montando ela no excel para ficar mais simples então não tenho que digitar uma a uma. Como estou tentando: "=CONCATENAR([@[Folder Path]];"> MOVE ";[@Name];" "; [@[Folder Path]];[@[Name short]])" que seria por exemplo c:\> move [nomeantigo] [nomenovo] D:\Documents\bilbio\es\ar-taubaté - SÃO JOSÉ DOS CAMPOS\ANEXO AO FÓRUM - ATIVO - AV SALMÃO, 678\Projetos\SÃO JOSÉ DOS CAMPOS - FORUM\Arquitetura\MP revisada Exec\> MOVE 01MP-TerreoREV.bak D:\Users\alessandramacedo\Documents\bilbio\es\ar-taubaté - SÃO JOSÉ DOS CAMPOS\ANEXO AO FÓRUM - ATIVO - AV SALMÃO, 678\Projetos\SÃO JOSÉ DOS CAMPOS - FORUM\Arquitetura\MP revisada Exec\01MP-Terre D:\Documents\bilbio\es\ar-taubaté - SÃO JOSÉ DOS CAMPOS\ANEXO AO FÓRUM - ATIVO - AV SALMÃO, 678\Projetos\SÃO JOSÉ DOS CAMPOS - FORUM\Arquitetura\SalãoJuri Exec\> MOVE 01Salão do JurI-Subsolo-24-03-10.bak D:\Users\alessandramacedo\Documents\bilbio\es\ar-taubaté - SÃO JOSÉ DOS CAMPOS\ANEXO AO FÓRUM - ATIVO - AV SALMÃO, 678\Projetos\SÃO JOSÉ DOS CAMPOS - FORUM\Arquitetura\SalãoJuri Exec\01Salão do D:\Documents\bilbio\es\ar-campinas - CAMPINAS\PRÓPRIO - ATIVO - AV. FRANCISCO XAVIER DE ARRUDA CAMARGO, 340 - 3 ANDAR\Projetos\PLANTAS DO PRÉDIO\> MOVE 03-CAMPINAS_inferior_AS BUILT NOV_2015.bak D:\Users\alessandramacedo\Documents\bilbio\es\ar-campinas - CAMPINAS\PRÓPRIO - ATIVO - AV. FRANCISCO XAVIER DE ARRUDA CAMARGO, 340 - 3 ANDAR\Projetos\PLANTAS DO PRÉDIO\03-CAMPINA D:\Documents\bilbio\es\ar-taubaté - SÃO JOSÉ DOS CAMPOS\ANEXO AO FÓRUM - ATIVO - AV SALMÃO, 678\Projetos\SÃO JOSÉ DOS CAMPOS - FORUM\Arquitetura\Varas Revisada\> MOVE 08Varas-DetalhesREV.bak D:\Users\alessandramacedo\Documents\bilbio\es\ar-taubaté - SÃO JOSÉ DOS CAMPOS\ANEXO AO FÓRUM - ATIVO - AV SALMÃO, 678\Projetos\SÃO JOSÉ DOS CAMPOS - FORUM\Arquitetura\Varas Revisada\08Varas-De Depois de subir tudo vou ter que renomear pastas e diretórios e arquivos e pretendo fazer ordenadamente por etapas porque são muitos dados. O pessoal usava nomes extensos para todos os caminhos, estou desenvolvendo manual para padronização e normatização. Se alguém souber ajudar agradeço..

Bom dia Tenho uma planilha com dados que precisam ser atualizados diariamente. O arquivo está salvo na nuvem e consta da pasta documento do SharePoint equipe. Desenvolvi um relatório no power bi para consulta por membros da equipe no site privado da mesma em SharePoint. tenho power bi pro mas os demais usuários não. Coloquei o relatório do power bi em web part do SharePoint mas não dá acesso a ninguém, mesmo autorizando as pessoas no power bi. Fiz então o mesmo painel em power view contudo dá erro e não abre. (contéudo não suportado) Pergunta 1: Se colocar um link do power bi público para acesso em uma web part no SharePoint privado da equipe, ainda assim meus dados poderão ser acessados por pessoas de fora da equipe? Considerando que o link não será enviado para ninguém de fora. Pergunta 2: Existe alguma outra forma de disponibilizar um painel consulta para os usuários? Pergunta 3: Como preciso dos dados e painel atualizados diariamente, a melhor forma seria programando gateway no SharePoint? Já tentei achar estas dúvidas na net, contudo não ficou claro para mim a questão de como disponibilizar relatórios quando nem todos são usuários pro. Se algum tiver uma luz, agradeço imensamente. Um ótimo dia para todos!!

Boa tarde Estou montando um arquivo em excel com vba para cadastro de diversas pedidos de engenharia (instalação ar condicionado, reparos, etc). Preciso salvar os pedidos em duas planilhas (porque o mesmo pedido pode ter mais de um aparelho de ar condicionado por exemplo). Então uma planilha "Ped" salva com id repetidos e outra salva valores totais dos pedidos (PedId). Fiz algo errado na fórmula para carregar registros desta planilha PedId. Não está carregando os dados na listview e textbox desta outra planilha. Só carrega os dados da planilha Ped. Poderiam ver o que fiz de errado e aproveitar e ver se o resto tá certinho se não for abusar? Preciso das datas salvas e carregadas como dd/mm/yyyy. e valores salvos como números porque vou somá-los para conferência de gastos. Segue arquivo .. Obrigada 05._Controle_Geral_site.zip

Bom dia Resolvi não complicar, e achei um código para enviar dados para mala direta do word conforme abaixo: Ele mescla todos e monta arquivo novo com base no modelo já pronto no word. Só que tá me dando erro de defina a variável: wdFormLetters Como faço? Vi uma solução que seria declarar Const wdFormLetters = 0, wdOpenFormatAuto = 0 Const wdSendToNewDocument = 0, wdDefaultFirstRecord = 1, wdDefaultLastRecord = -16 Mas como sei os dados que tenho que colocar? Obrigada Private Sub btn_montar_contrato_Click() Dim wd As Object Dim wdocSource As Object Dim strWorkbookName As String On Error Resume Next Set wd = CreateObject("Word.Application") On Error GoTo 0 Set wdocSource = wd.Documents.Open(ActiveWorkbook.Path & "\contrato_modelo_specialle.docx") strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name wdocSource.MailMerge.MainDocumentType = wdFormLetters wdocSource.MailMerge.OpenDataSource _ Name:=strWorkbookName, _ AddToRecentFiles:=False, _ Revert:=False, _ Format:=wdOpenFormatAuto, _ Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _ SQLStatement:="SELECT * FROM `Contatos$`" With wdocSource.MailMerge .Destination = wdSendToNewDocument .SuppressBlankLines = True With .DataSource ' aqui eu limito para quem será gerada a ficha, no caso somente para o cliente selecionado, pois, do contrário ele sempre gerará para todos os clientes da planilha '.FirstRecord = txt_a_numerocliente ' este é o nome da textbox onde fica o número do cliente '.LastRecord = txt_a_numerocliente .FirstRecord = wdDefaultFirstRecord .LastRecord = wdDefaultLastRecord End With .Execute Pause:=False End With wd.Visible = True wdocSource.Close SaveChanges:=False Set wdocSource = Nothing Set wd = Nothing End Sub

@Basole Aparentemente está certinho agora, vou fazer mais uns testes mas valeu!! você arrasa sempre, obrigada!

Bom dia Estou quebrando a cabeça mas não consegui solucionar, se alguém souber agradeço. Tenho um codigo para busca por cadastros, mas tem algum erro, porque quando busco código "8135", está me retornando os dados do código "8121", ou seja está pegando os dois primeiros números somente. Como faço para transformar esta busca para o número inteiro somente? segue código usado. Obrigada If txt_buscaeng = "" Then MsgBox ("Digite ENG a ser procurado") Exit Sub End If Dim eng eng = Format(Me.txt_buscaeng, "####") Call Conecta ComandoSQL = "select * from Tabela_expedientes" Set consulta = Banco.OpenRecordset(ComandoSQL) While Not consulta.EOF If consulta("eng") = eng Then txt_codigo = consulta("ID") GoTo fim End If consulta.MoveNext Wend MsgBox "Numero Eng não encontrado!" Call Desconecta Exit Sub fim: Call Desconecta valor = Me.txt_codigo - 1 txt_buscaeng = "" txt_eng = "" btn_proximo_Click Call carrega_pesquisa

Ainda sem conseguir nada parecido, alguém já fez algo neste sentido?

Bom dia, estou desenvolvendo uma mala direta em excel vba e word a partir de um modelo existente e estou com problemas no desenvolvimento de alguns códigos: 1) Preciso carregar a foto no word a partir do código em excel, alguem tem algum modelo de código? Ao escolher o grupo preciso que busque a logo correspondente e carregue onde está a inscrição #FOTO no documento word. 2) como faço para ao escolher o botão word, ele tbem permita a inclusão de arquivo que será a páguina dois do documento word, e será variavel? teria que abrir a opção de escolher arquivo e automaticamente incluir como folha dois.. 3) Preciso ao escolher o grupo, e ao escolher a página 2, que automaticamente ele mescle todos os registros deste grupo no word e crie novo arquivo mesclado para impressão que deverá ser frente e verso. A folha gerada será colocada em autoenvelopadora. É possivel fazer da forma como estou pensando? se alguém já tiver feito algo parecido e tiver uma luz, agradeço. Vou anexar os arquivos para melhor entendimento. Obrigada MALA DIRETA.zip

deu certinho assim: Private Sub Workbook_AfterSave(ByVal Success As Boolean) Dim wExpedientes As Workbook, wcola As Workbook Set wExpedientes = Workbooks.Open(Replace(ThisWorkbook.Path, "01-Controle_Unidades", vbNullString) & "05-Banco_de_Dados_Engenharia\ARQUIVO DE DADOS.XLSM", ReadOnly:=False) Set wcola = ThisWorkbook ThisWorkbook.Sheets("Importa_Access").Range("A1").Select Range("a2:dd50000").Select Selection.Copy wExpedientes.Activate wExpedientes.Sheets("REGISTRO ENDEREÇOS").Select Range("a2:dd50000").Select Selection.PasteSpecial xlPasteValues Application.CutCopyMode = False Application.DisplayAlerts = False wExpedientes.Close SaveChanges:=True On Error Resume Next End Sub valeu !!

Boa tarde.. Preciso que toda vez que atualizar um arquivo front end no excel, que ele salve os dados da planilha ("Importa_Access") para outro arquivo sobrescrevendo os dados da planilha ("registro de endereços"). consigo o que quero se colocar no esta pasta de trabalho o código abaixo: porque tá criando conexão, não sei se tem algum jeito mais fácil e correto de fazer. Obrigada Option Explicit Private Sub Workbook_AfterSave(ByVal Success As Boolean) Dim wb As Workbook Dim ws As Worksheet Set ws = Worksheets("Importa_Access") Set wb = Workbooks.Open(Replace(ThisWorkbook.Path, "01-Controle_Unidades", "05-Banco_de_Dados_Engenharia\") & "ARQUIVO DE DADOS.xlsm") ws.Range("a1:dd10000").Copy Destination:=Workbooks(wb.Name).Sheets("REGISTRO ENDEREÇOS").Range("A1") wb.Save wb.Close Set wb = Nothing End Sub

@basole Consegui com este codigo: Sub filtro_multi() On Error GoTo trata_erro Dim data_ini As Date Dim data_fim As Date Dim busca_endereco As String Dim busca_pendencia As String Dim busca_cidade As String Dim busca_regional As String Dim busca_tipo As String Dim busca_situacao As String Dim ComandoSQL As String busca_pendencia = Me.cmb_buscapendencia busca_endereco = Me.cmb_buscaendereco busca_cidade = Me.cmb_buscacidade busca_regional = Me.cmb_buscaregional busca_tipo = Me.cmb_buscatipo busca_situacao = Me.cmb_buscasituacao If Me.cmb_buscapendencia = "" Then ComandoSQL = "select * from Tabela1 where endereco like '*" & busca_endereco & "*' and " ComandoSQL = ComandoSQL & "Cidade like '*" & busca_cidade & "*' and " ComandoSQL = ComandoSQL & "Regional like '*" & busca_regional & "*' and " ComandoSQL = ComandoSQL & "Tipo like '*" & busca_tipo & "*' and " ComandoSQL = ComandoSQL & "Situacao like '*" & busca_situacao & "*' " Else ComandoSQL = "select * from Tabela1 where endereco like '*" & busca_endereco & "*' and " ComandoSQL = ComandoSQL & "Cidade like '*" & busca_cidade & "*' and " ComandoSQL = ComandoSQL & "Regional like '*" & busca_regional & "*' and " ComandoSQL = ComandoSQL & "Tipo like '*" & busca_tipo & "*' and " ComandoSQL = ComandoSQL & "Situacao like '*" & busca_situacao & "*' and " ComandoSQL = ComandoSQL & busca_pendencia & " like true " End If Call Conecta Set consulta = banco.OpenRecordset(ComandoSQL) On Error Resume Next ListBox1.Clear While Not consulta.EOF With Me.ListBox1 .AddItem .List(linhalistbox, 0) = consulta(0) .List(linhalistbox, 1) = consulta(1) .List(linhalistbox, 2) = consulta(2) .List(linhalistbox, 3) = consulta(3) .List(linhalistbox, 4) = consulta(5) .List(linhalistbox, 5) = consulta(47) End With linhalistbox = linhalistbox + 1 consulta.MoveNext Wend Me.lbl_registros = Me.ListBox1.ListCount Call Desconecta Exit Sub trata_erro: MsgBox "OPS! Certifique-se que os valores digitados estão corretos!", vbInformation, "Erro Pesquisa" End Sub Valeu adicionado 2 minutos depois

@basole segue arquivo, o frmpesquisa. obrigada Gestão - Endereços_pesquisa.rar

Mais um pepino que não consigo resolver.. preciso fazer uma pesquisa multicritério via vba (banco de dados access), com um dos critérios (coluna de pendencia) variavel. Ou seja defino a pendência, ele faz a busca na coluna relativa a esta pendência e lista todos os registros que constarem como "True" para ela. (checkbox) MOntei o código assim, mas sei que está errado por conta da variavel.. Alguém sabe desenvolver este código por favor? obrigada Sub filtro_multi() On Error GoTo trata_erro Dim data_ini As Date Dim data_fim As Date Dim variavel As Variant Dim busca_cidade As String Dim busca_regional As String Dim busca_tipo As String Dim busca_situacao As String Dim strString As String: strString = "[" & variavel_string & "]" Dim ComandoSQL As String strString = Me.txt_coluna busca_endereco = Me.cmb_buscaendereco busca_cidade = Me.cmb_buscacidade busca_regional = Me.cmb_buscaregional busca_tipo = Me.cmb_buscatipo busca_situacao = Me.cmb_buscasituacao ComandoSQL = "select * from Tabela1 where endereco like '*" & busca_endereco & "*' and " ComandoSQL = ComandoSQL & "cidade like '*" & busca_cidade & "*' and " ComandoSQL = ComandoSQL & "regional like '*" & busca_regional & "*' and " ComandoSQL = ComandoSQL & "tipo like '*" & busca_tipo & "*' and " ComandoSQL = ComandoSQL & "situacao like '*" & busca_situacao & "*' and " ComandoSQL = ComandoSQL & "strString like '*" & "True" & "*'" Call Conecta Set consulta = banco.OpenRecordset(ComandoSQL) On Error Resume Next ListBox1.Clear While Not consulta.EOF With Me.ListBox1 .AddItem .List(linhalistbox, 0) = consulta(0) .List(linhalistbox, 1) = consulta(1) .List(linhalistbox, 2) = consulta(2) .List(linhalistbox, 3) = consulta(3) .List(linhalistbox, 4) = consulta(5) .List(linhalistbox, 5) = consulta(47) End With linhalistbox = linhalistbox + 1 consulta.MoveNext Wend Me.lbl_registros = Me.ListBox1.ListCount Call Desconecta Exit Sub trata_erro: MsgBox "OPS! Certifique-se que os valores digitados estão corretos!", vbInformation, "Erro Pesquisa" End Sub

@Basole perfeito, muito obrigada adicionado 4 minutos depois como encerro? rs adicionado 32 minutos depois @Basole Fui fazer o teste e quando tem fotos, tá carregando mas a última da listbox, como faço para pegar a primeira?

Boa tarde a todos. Estou fazendo um arquivo de ficha para impressão via código vba e preciso que a planilha no excel carrega a primeira foto do listbox1, ou se não houver foto cadastrada carregue "SEM FOTO.JPG". está me dando erro na linha em vermelho. Erro tempo de execução 381. alguma luz do que fiz errado? Obrigada With Worksheets("FICHA ENDEREÇO") On Error Resume Next caminho = Me.txt_dir If Me.ListBox1.ListIndex = "" Then Worksheets("FICHA ENDEREÇO").imgfoto.Picture = LoadPicture(caminho & "\" & "SEMFOTO.JPG") Worksheets("FICHA ENDEREÇO").imgfoto.PictureSizeMode = fmPictureSizeModeStretch Else 'quero carregar a primeira foto da lisbox1 Worksheets("FICHA ENDEREÇO").imgfoto.Picture = LoadPicture(caminho & "\" & Me.ListBox1.List(ListBox1.ListIndex)) Worksheets("FICHA ENDEREÇO").imgfoto.PictureSizeMode = fmPictureSizeModeStretch End If End With

encontrei um código na net mas não consigo adaptá-lo. Fonte: http://guiadoexcel.com.br/criar-pastas-automaticamente-com-vba segue: Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _ "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _ "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _ As Long Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Private Sub lsCriarPasta(ByVal lPasta As String) On Error Resume Next MkDir lPasta End Sub Public Sub lsCriarPastas() Dim iTotalLinhas As Long Dim i As Long iTotalLinhas = Worksheets("Menu").Cells(Worksheets("Menu").Rows.Count, 1).End(xlUp).Row i = 1 While i <= iTotalLinhas lsCriarPasta Range("A" & i).Value i = i + 1 Wend gfMens "Pastas Criadas!" End Sub

Bom dia Tenho um arquivo com dados e gostaria de criar pastas e subpastas em meu computador automaticamente. o arquivo possui 2 colunas. As pastas da coluna A já estão criadas no computador, preciso que o código busque estas pastas para cada dado da coluna B e identificando crie automaticamente subpasta com nome constante na coluna B. o arquivo ficaria depois de feito: pasta : ar-araçatuba - ANDRADINA subpastas: 1) FÓRUM - ATIVO - RUA SÃO PAULO, 957 2) FÓRUM - ATIVO - RUA PAES LEME, 205 Depois preciso que em cada subpasta sejam criadas 5 pastas iguais para todas as subpastas. seriam: "Dados do imóvel"; "Patrimônio"; "Relatórios Trimestrais"; "Vistorias Técnicas"; "Expedientes" COLUNA A PASTA COLUNA B SUBPASTA ar-araçatuba - ANDRADINA FÓRUM - ATIVO - RUA SÃO PAULO, 957 ar-araçatuba - ANDRADINA FÓRUM - ATIVO - RUA PAES LEME, 2052 ar-araçatuba - ARAÇATUBA PRÓPRIO - ATIVO - AV. JOAQUIM POMPEU DE TOLEDO, 1261 ar-araçatuba - ARAÇATUBA TERRENO - ATIVO - RUA BERNARDINO DE CAMPOS, S/N ar-araçatuba - BILAC FÓRUM - ATIVO - RUA OLAVO BILAC, 466 ar-araçatuba - BIRIGUI PRÓPRIO - ATIVO - RUA FRANCISCO MARTINS ARCHILA, 222-232 ar-araçatuba - BURITAMA FÓRUM - ATIVO - AV. FREI MARCELO MANÍLIA, 739 ar-araçatuba - CAFELÂNDIA FÓRUM - ATIVO - AV. DIONÍSIA ZUCCHI, 330

Bom dia Estou adaptando um projeto de acompanhamento de obra com gráfico gantt para uso via vba. Estou com problemas na adptação. 1 - o form não carrega opor erro no datadiff 2 - o form para visualização da impressão eu adaptei de um modelo do Renan mas não sei onde alterar para buscar em landscape. Como está está comendo parte da planilha na visualização. Se puderem ver onde errei agradeço. Estou anexando os arquivos. Obrigada mais uma vez Arquivo Fórum.zip

estou transformando o arquivo para banco de dados em access. então vou postar no local correto. obrigada

resolvido

Bom dia Estou finalizando um projeto para minha área e estou com problema em 3 formulários. Erros que encontrei: frmconspend não funciona - fiz em cima de modelo de filtro avançado com multi critérios e adaptei para listbox. (aqui nem todos computadores aceitam listview) - modelo de LOGICA VBA frmRegionais - procura tá dando problema nas regionais de Grande SPaulo I, II e III, acredito que por começarem com nome igual - não carrega a foto quando clica em imprimir ficha (estranho porque no outro form de endereço carrega normalmente) - coloquei a listbox para aparecer o cabeçalho mas não sei por que não aparece (primeira linha) frmExpedientes - tentei fazer com que escolhendo um optionbotton, o combobox carregasse com dados do tipo escolhido de option. Não consegui. Este são os erros que encontrei mas gostaria se possível que dessem uma olhada geral para possiveís erros que gerariam bugs futuros. Fiquei sabendo que esta planilha será usada por outras áreas hoje e estou de cabelo em pé rs (imaginem 20 usuários de diferentes unidades).. Meus conhecimentos de vba são básicos, e tudo que faço é com ajuda de vocês e dos modelos que disponibilizam. Agradeço imensamente. Não consigo postar o arquivo zipado pois é maior que o permitido para anexo, eu posso usar tipo send space para postar? Alessandra

oi consegui com o seguinte código: 'Modelo de Aplicativo de Cadastro em VBA no Microsoft Excel 'Autor: Tomás Vásquez 'http://www.tomasvasquez.com.br 'http://tomas.vasquez.blog.uol.com.br 'março de 2008 Option Explicit Const colENDEREÇO As Integer = 2 Const colCIDADE As Integer = 3 Const colREGIONAL As Integer = 4 Const colTIPO As Integer = 6 Const colÁREA_DISPONÍVEL_MP As Integer = 17 Const colLOCAÇÃO_MENSAL As Integer = 19 Const colVIGÊNCIA As Integer = 20 Const colMEMBRO As Integer = 34 Const COLSITUAÇÃO As Integer = 42 Const indiceMinimo As Byte = 2 Const corDisabledTextBox As Long = -2147483633 Const corEnabledTextBox As Long = -2147483643 Private wsCadastro As Worksheet Private wbCadastro As Workbook Private valor_pesquisado As String Private Sub btnCancelar_Click() Unload Me frmCadastro.Show End Sub Private Sub frmRegistro_Click() End Sub Private Sub ListBox1_Click() End Sub Private Sub TxtRegional_Change() Application.DisplayAlerts = False Application.ScreenUpdating = False valor_pesquisado = TxtRegional.Text Call CarregaDadosInicial Call AtualizaFicha Call EnviarExcel Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub Private Sub UserForm_Initialize() Application.DisplayAlerts = False Application.ScreenUpdating = False Call DefinePlanilhaDados Call Limpa Call CarregaDadosInicial Call EnviarExcel TxtRegional.SetFocus Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Private Sub CarregaDadosInicial() Dim linha As Integer Dim coluna As Integer Dim linhalistbox As Integer Dim valor_celula As String Dim conta_registros As Integer linha = 2 coluna = 4 'coluna da busca na planilha linhalistbox = 0 conta_registros = 0 ListBox1.Clear With wsCadastro While .Cells(linha, coluna).Value <> Empty valor_celula = .Cells(linha, coluna).Value If UCase(Left(valor_celula, Len(valor_pesquisado))) = UCase(valor_pesquisado) Then With ListBox1 ListBox1.ColumnWidths = "500;120;120;80;80;80;80;60;60" .AddItem .List(linhalistbox, 0) = wsCadastro.Cells(linha, 2) .List(linhalistbox, 1) = wsCadastro.Cells(linha, 3) .List(linhalistbox, 2) = wsCadastro.Cells(linha, 4) .List(linhalistbox, 3) = wsCadastro.Cells(linha, 6) .List(linhalistbox, 4) = wsCadastro.Cells(linha, 17) .List(linhalistbox, 5) = Format(wsCadastro.Cells(linha, 19), "R$ #.###,##") .List(linhalistbox, 6) = Format(wsCadastro.Cells(linha, 20), "dd/mm/yyyy") .List(linhalistbox, 7) = wsCadastro.Cells(linha, 34) .List(linhalistbox, 8) = wsCadastro.Cells(linha, 42) linhalistbox = linhalistbox + 1 conta_registros = conta_registros + 1 End With End If linha = linha + 1 Wend End With If ListBox1.ListCount > 0 Then lbl_registros = ListBox1.ListCount - 1 Else lbl_registros = "0" End If End Sub Private Sub DefinePlanilhaDados() Dim abrirArquivo As Boolean Dim WB As Workbook Dim caminhoCompleto As String Dim ARQUIVO_DADOS As String Dim PASTA_DADOS As String abrirArquivo = True ARQUIVO_DADOS = Range("ARQUIVO_DADOS").Value PASTA_DADOS = Range("PASTA_DADOS").Value If ThisWorkbook.Name <> ARQUIVO_DADOS Then 'monta a string do caminho completo If PASTA_DADOS = vbNullString Or PASTA_DADOS = "" Then caminhoCompleto = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, vbNullString) & ARQUIVO_DADOS Else If Right(PASTA_DADOS, 1) = "\" Then caminhoCompleto = PASTA_DADOS & ARQUIVO_DADOS Else caminhoCompleto = PASTA_DADOS & "\" & ARQUIVO_DADOS End If End If 'verifica se o arquivo não está aberto For Each WB In Application.Workbooks If WB.Name = ARQUIVO_DADOS Then abrirArquivo = False Exit For End If Next 'atribui o arquivo If abrirArquivo Then Set wbCadastro = Workbooks.Open(FileName:=caminhoCompleto, ReadOnly:=True) Else Set wbCadastro = Workbooks(ARQUIVO_DADOS) End If Else Set wbCadastro = ThisWorkbook End If Set wsCadastro = wbCadastro.Worksheets("REGISTRO ENDEREÇOS") 'oculta o arquivo de dados wbCadastro.Windows(1).Visible = False End Sub Private Sub CommandButton2_Click() If TxtRegional = "" Then Exit Sub Else Call AtualizaFicha Sheets("FICHA REGIONAL").Select frmFichaRegional.Show End If End Sub Private Sub AtualizaFicha() Application.DisplayAlerts = False Application.ScreenUpdating = False Sheets("FICHA REGIONAL").Select Range("C2") = Me.TxtRegional Sheets("REGISTRO REGIONAIS").Select Range("a1").Select Dim Rng As Range Set Rng = Sheets("REGISTRO REGIONAIS").Cells.Find(What:=TxtRegional.Value, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) If Not Rng Is Nothing Then Sheets("FICHA REGIONAL").Select Sheets("FICHA REGIONAL").imgReg.Picture = LoadPicture(ThisWorkbook.Path & "\FOTOS UNIDADES\" & Rng.Offset(, 1)) Sheets("FICHA REGIONAL").imgReg.PictureSizeMode = fmPictureSizeModeStretch Application.DisplayAlerts = True Application.ScreenUpdating = True End If End Sub Private Sub EnviarExcel() Application.DisplayAlerts = False Application.ScreenUpdating = False 'cria varíavel para contagem da linha a ser preenchida Dim Nlin As Integer 'cria uma variável para contar as linhas da listbox Dim Cont As Integer 'limpa a região com dados anteriores Worksheets("FICHA REGIONAL").Range("A32:I1000").ClearContents 'linha inicial da planilha que carregará os dados Nlin = 31 'preenche as outras linhas até o fim da listbox For Cont = 0 To Me.ListBox1.ListCount - 1 Worksheets("FICHA REGIONAL").Range("A" & Nlin + 1) = Me.ListBox1.List(Cont, 0) Worksheets("FICHA REGIONAL").Range("B" & Nlin + 1) = Me.ListBox1.List(Cont, 1) Worksheets("FICHA REGIONAL").Range("C" & Nlin + 1) = Me.ListBox1.List(Cont, 2) Worksheets("FICHA REGIONAL").Range("D" & Nlin + 1) = Me.ListBox1.List(Cont, 3) Worksheets("FICHA REGIONAL").Range("E" & Nlin + 1) = Me.ListBox1.List(Cont, 4) Worksheets("FICHA REGIONAL").Range("F" & Nlin + 1) = Format(Me.ListBox1.List(Cont, 5), "R$ #.###,##") Worksheets("FICHA REGIONAL").Range("G" & Nlin + 1) = Format(Me.ListBox1.List(Cont, 6), "dd/mm/yyyy") Worksheets("FICHA REGIONAL").Range("H" & Nlin + 1) = Me.ListBox1.List(Cont, 7) Worksheets("FICHA REGIONAL").Range("I" & Nlin + 1) = Me.ListBox1.List(Cont, 8) Nlin = Nlin + 1 Next Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub Sub Limpa() Worksheets("FICHA REGIONAL").Select Range("a32").Select Range(Selection, Selection.End(xlToRight)).Select Range(Selection, Selection.End(xlDown)).Select Selection.ClearContents Range("a32").Select On Error Resume Next End Sub Valeu a todos pela ajuda, e fica o código que consegui se alguém precisar. Obrigada

boa tarde tenho o código abaixo que está dando certinho. Contudo alguns computadores não estão aceitando listview. Queria então trocar a listview2 por uma listbox1. Poderiam me ajudar na adaptação do código? Tentei mas to meio que boiando e não deu certo. Se puderem ajudar agradeço. código com listview: Dim wbCadastro As WorkbookDim wsCadastro As Worksheet'Desenvolvido por Renam Fernando Ruthes'Canal Lógica VBA - YouTube'email: [email protected] Sub btn_filtro_Click()Me.ListView2.Height = 210Me.ListView2.Top = 150Me.CmbRegional = ""ThisWorkbook.Sheets("Filtro").SelectThisWorkbook.Sheets("Filtro").Cells(2, 1) = ""Call limpaCall copiaMe.CmbRegional.SetFocusEnd SubPrivate Sub btnCancelar_Click()Unload MefrmCadastro.ShowEnd SubPrivate Sub CmbRegional_Change() 'Muda a cor se tiver conteúdoIf Me.CmbRegional = "" ThenCmbRegional.BackColor = &HFFFFFFElseCmbRegional.BackColor = &H80C0FFEnd IfSheets("Filtro").SelectRange("a2") = Me.CmbRegionalCall pesquisaCall listaCall AtualizaFicha'lbl_registros = Me.ListView2.ListItems.CountEnd SubSub lista()ListView2.ListItems.Clearlbl_registros = ""'Adiciona os dados a listview2ThisWorkbook.Sheets("Filtro").Select lin = 5 Do Until ThisWorkbook.Sheets("Filtro").Cells(lin, 1) = "" If Cells(lin, 1).Rows.Hidden = False Then Set li = ListView2.ListItems.Add(Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 88).Value) 'ENDEREÇO li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 89).Value 'CIDADE li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 90).Value 'TIPO li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 91).Value 'ÁREADISPONIVELMP li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 92).Value 'LOCAÇÃO MENSAL li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 93).Value 'VIGENCIA li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 94).Value 'MEMBROS End If lin = lin + 1 Loop 'lbl_registros = Me.ListView2.ListItems.Count End SubPrivate Sub CommandButton2_Click()Application.ScreenUpdating = FalseCall AtualizaFichaThisWorkbook.Sheets("FICHA REGIONAL").SelectRange("D2") = Me.CmbRegional If CmbRegional = "" Then End If If Range("D2") = "" Then 'nada faz Else Range("a32").Select Range(Selection, Selection.End(xlToRight)).Select Range(Selection, Selection.End(xlDown)).Select Selection.ClearContents Range("a32").Select End If Range("a32").Select Dim i As Integer, j As Integer 'Loop das linhas For i = 1 To ListView2.ListItems.Count Cells(i + 31, 1) = ListView2.ListItems(i).Text 'Loop das colunas For j = 1 To ListView2.ColumnHeaders.Count - 1 Cells(i + 31, j + 1) = ListView2.ListItems(i).ListSubItems(j).Text Next j Next i Unload Me frmFichaRegional.Show Application.ScreenUpdating = TrueEnd SubPrivate Sub TextBox1_Change()End SubPrivate Sub UserForm_Initialize() Application.ScreenUpdating = FalseCall DefinePlanilhaDadosCall copiaListView2.ListItems.Clear'configura o tamamanho inicial do form a altua da listview e sua posiçãoMe.ListView2.Height = 230Me.ListView2.Top = 150' Adiciona as colunas a ListView2 With ListView2 .Gridlines = True .View = lvwReport .FullRowSelect = True .ColumnHeaders.Add Text:="Endereço", Width:=200 .ColumnHeaders.Add Text:="Cidade", Width:=100 .ColumnHeaders.Add Text:="Tipo", Width:=60, Alignment:=2 .ColumnHeaders.Add Text:="Área Disponível MPSP, Width:=30, Alignment:=2" .ColumnHeaders.Add Text:="Locação Mensal", Width:=60, Alignment:=2 .ColumnHeaders.Add Text:="Vigência", Width:=60, Alignment:=2 .ColumnHeaders.Add Text:="Membros", Width:=60, Alignment:=2 End WithListView2.ListItems.Clear'Adiciona os dados a listview2ThisWorkbook.Sheets("Filtro").Select lin = 5 Do Until ThisWorkbook.Sheets("Filtro").Cells(lin, 1) = "" If Cells(lin, 1).Rows.Hidden = False Then Set li = ListView2.ListItems.Add(Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 88).Value) 'ENDEREÇO li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 89).Value 'CIDADE li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 90).Value 'TIPO li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 91).Value 'ÁREADISPONIVELMP li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 92).Value 'LOCAÇÃO MENSAL li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 93).Value 'VIGENCIA li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 94).Value 'MEMBROS End If lin = lin + 1 Loop 'lbl_registros = Me.ListView2.ListItems.Countlinha = 2Do Until ThisWorkbook.Sheets("REGISTRO REGIONAIS").Cells(linha, 2) = "" CmbRegional.AddItem ThisWorkbook.Sheets("REGISTRO REGIONAIS").Cells(linha, 2) '1 refere-se a 1ª coluna onde estão os dados ref. regional linha = linha + 1Loop Application.ScreenUpdating = TrueEnd SubPrivate Sub DefinePlanilhaDados() Dim abrirArquivo As Boolean Dim WB As Workbook Dim caminhoCompleto As String Dim ARQUIVO_DADOS As String Dim PASTA_DADOS As String abrirArquivo = True ARQUIVO_DADOS = "BANCO DE DADOS ENGENHARIA.xlsm" If ThisWorkbook.Name <> ARQUIVO_DADOS Then 'monta a string do caminho completo caminhoCompleto = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, vbNullString) & ARQUIVO_DADOS End If 'verifica se o arquivo não está aberto For Each WB In Application.Workbooks If WB.Name = ARQUIVO_DADOS Then abrirArquivo = False Exit For End If Next 'atribui o arquivo If abrirArquivo Then Set wbCadastro = Workbooks.Open(FileName:=caminhoCompleto, ReadOnly:=True) Else Set wbCadastro = Workbooks("BANCO DE DADOS ENGENHARIA.xlsm") End If Set wsCadastro = wbCadastro.Worksheets("REGISTRO ENDEREÇOS") 'oculta o arquivo de dados wbCadastro.Windows(1).Visible = False End SubPrivate Sub limpa() Worksheets("Filtro").Select Range("a5").Select Range(Selection, Selection.End(xlToRight)).Select Range(Selection, Selection.End(xlDown)).Select Selection.ClearContents Range("a5").Select On Error Resume Next End SubPrivate Sub copia() ThisWorkbook.Sheets("Filtro").Visible = True Call limpa Dim intervalo As Range Dim intervalo2 As Range wbCadastro.Activate wbCadastro.Sheets("registro endereços").Select Set intervalo = wbCadastro.Sheets("registro endereços").Range("a1:ci1000") intervalo.Copy ThisWorkbook.Activate Worksheets("Filtro").Select Worksheets("Filtro").Range("A4").Select Selection.PasteSpecial Paste:=xlPasteValues Set intervalo2 = ActiveSheet.Range("a4:ci1000") intervalo2.RemoveDuplicates Columns:=1, Header:=xlNo '*** Copy the action Summary data from each original Action Plan ***End SubPrivate Sub pesquisa() ThisWorkbook.Sheets("Filtro").Select ThisWorkbook.Sheets("Filtro").Range("A4").Select ThisWorkbook.Sheets("Filtro").Range("A4:CI1000").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _ ("A1:B3"), CopyToRange:=Range("CJ4:Cp4"), Unique:=FalseEnd SubPrivate Sub AtualizarArquivo(ByVal ReadOnly As Boolean) End SubPrivate Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Call AtualizarArquivo(True) If CloseMode = vbFormControlMenu Then Cancel = True MsgBox "Favor clique no botão VOLTAR" _ , vbCritical _ , "Erro" End If End SubPrivate Sub AtualizaFicha()Sheets("FICHA REGIONAL").SelectRange("C2") = Me.CmbRegionalSheets("REGISTRO REGIONAIS").SelectRange("a1").SelectDim Rng As Range Set Rng = Sheets("REGISTRO REGIONAIS").Cells.Find(What:=CmbRegional.Value, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) If Not Rng Is Nothing Then txtfoto.Value = Rng.Offset(, 1) End If Sheets("FICHA REGIONAL").SelectWith imgRegSheets("FICHA REGIONAL").imgReg.Picture = LoadPicture(ThisWorkbook.Path & "\FOTOS UNIDADES\" & txtfoto)Sheets("FICHA REGIONAL").imgReg.PictureSizeMode = fmPictureSizeModeStretchEnd With Sheets("FICHA ENDEREÇO").Select End Sub