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

 

@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

 

como encerro? rs

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

 

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