Copiar dados de planilhas diferentes VBA

[Fernanda Sanches]

Boa tarde,

 

Tenho um problemão para resolver. E como estou começando a mexer com o código VBA no excel não tenho ideia de como solucionar isso.

 

Tenho duas pastas excel diferentes que serão salvas na rede do escritório.

Na pasta excel 1 há um banco de dados de clientes da empresa.

Na pasta excel 2 há o relatório emitido por outro departamento da empresa com o nome e processos de cada cliente.

 

o problema é o seguinte: o relatório emitido mensalmente pelo outro departamento há o mesmo cliente mais de uma vez na mesma planilha por conter erros ortográficos.

Eu preciso deste relatório mensal para emitir um outro relatório, só que eu não posso usar nenhuma fórmula justamente porque contem esses erros ortográficos e os valores de um cliente irão aparecer em 3 clientes (que é o mesmo cliente na verdade, mas que por esses erros ortográficos o cliente aparece 3 vezes na mesma planilha).

 

A solução que eu pensei foi a seguinte: Fazer um autocompletar.

 

Origem do banco de dados: A pasta excel 1 que é o banco de dados dos clientes da empresa (está na rede mas está fechada e eu não quero que ela abra com a aquele comando Workbook("x").Open (ou algo assim rs)).

 

Destino: Textbox de um formulário ou se for possível na própria célula da planilha.

 

Será usando apenas uma coluna e uma planilha de cada pasta (origem/destino).

 

Só que aí entra um outro problema.... E se o departamento tiver um novo nome do cliente que não está no banco de dados?

 

O que eu pensei foi em que o departamento está habilitado a adicionar novos clientes e este será adicionado automaticamente na pasta excel de banco de dados (fechada). E se a pessoa apertar o botão "Adicionar Novo" com o nome do cliente já existente no banco de dados aparecerá o erro de cliente duplicado.

 

Não sei se consegui explicar muito bem.... rsrs

 

Qualquer dúvida, por favor, me informem.

 

Segue a planilha como um exemplo do que eu consegui fazer até o momento, só que o banco de dados e o relatório estão em um mesmo arquivo e eu só consigo adicionar o nome de cliente novo na aba do banco de dados mas o mesmo não aparece na aba do relatório.

 

https://www.sendspace.com/file/8ostvs  

 

O que eu fiz até o momento foi com base no link abaixo:

 

http://guiadoexcel.com.br/auto-completar-em-excel-vba

 

Vocês podem me ajudar, por favor? 

 

Muito obrigada mesmo!!

[Visitante]

Olá, Fernanda.

O recurso "Validação de dados" poderia te ajudar.

Aplique a "Validação" na coluna Cliente do Relatório com base na lista de clientes do Banco de Dados de Clientes.

[Xflapc2]

porque nao usam CPF como campo de chave mestra? mais fácil ja que é unico, nome é complicado.

 

Como o colega disse o jeito do jeito que está seria criar uma regra de validação, mas há um complicador

pois a pessoa poderá adicionar a mesma pessoas 2 ou mais vezes na 1a planilha

nesse caso você teria que implementar o controle com uma coluna que contasse as aparições daquele nome da linha pras anteriores

[Fernanda Sanches]

Bom dia,

 

Muito obrigada pelo retorno de vocês!!

 

Eu já tentei a validação de dados, só que ele não aceita pegar a informação de outro arquivo excel somente do mesmo arquivo, pelo menos eu não consegui... E o que eu preciso é usar como fonte de dados um arquivo excel que está fechado.

Pegar dados de um arquivo excel fechado já consegui fazer com o código abaixo

'Executar esta rotina para testar a função ObterDadosExternosSub Teste()         Dim sCaminho As String    Dim sPastaDeTrabalho As String    Dim sPlanilha As String    Dim sEndereço As String        sCaminho = "C:\Users\fernanda.rocha\Desktop\"    sPastaDeTrabalho = "banco de dados.xlsx"    sPlanilha = "Plan1"    sEndereço = "A:A"        'Imprime valor do endereço acima da janela de Verificação imediata:    Debug.Print ObterDadoExterno2(sCaminho, sPastaDeTrabalho, sPlanilha, sEndereço)End Sub Function ObterDadoExterno(sCaminho As String, _                            sPastaDeTrabalho As String, _                            sPlanilha As String, _                            sEndereço As String)        Dim sDado As String        'É necessário que o caminho termine com uma \    If Right(sCaminho, 1) <> "\" Then        sCaminho = sCaminho & "\"    End If        sDado = "'" & sCaminho & "[" & sPastaDeTrabalho & "]" & _      sPlanilha & "'!" & ThisWorkbook.Sheets(1).Range(sEndereço).Address(, , xlR1C1)        ObterDadoExterno = ExecuteExcel4Macro(sDado)End FunctionFunction ObterDadoExterno2(sCaminho As String, _                            sPastaDeTrabalho As String, _                            sPlanilha As String, _                            sEndereço As String)        Dim sDado As String        'É necessário que o caminho termine com uma \    If Right(sCaminho, 1) <> "\" Then        sCaminho = sCaminho & "\"    End If        sDado = "'" & sCaminho & "[" & sPastaDeTrabalho & "]" & _      sPlanilha & "'!" & Range(sEndereço).Address(, , xlR1C1)        Debug.Print Evaluate("='" & sCaminho & "[" & sPastaDeTrabalho & "]" & _      sPlanilha & "'!" & sEndereço)        Range("A1") = "='" & sCaminho & "[" & sPastaDeTrabalho & "]" & _      sPlanilha & "'!" & sEndereço    'ObterDadoExterno2 = "="End Function

Não deixar que a pessoa coloque mais de uma vez o mesmo cliente e se for um novo cliente adicionar no banco de dados de clientes eu consigo com o código abaixo. Tenho 3 problemas:

 

1. eu não consigo fazer com que o novo nome que foi adicionado na aba com os nomes dos clientes apareça também na aba relatório (ao mesmo tempo).

2. o arquivo com os nomes dos clientes está aberto. Quero adicionar a nova informação com a planilha fechada.

3. o nome dos clientes e o relatório estão em um mesmo arquivo excel e eu preciso que sejam arquivos separados.

Dim iRow As LongDim ws As WorksheetSet ws = Worksheets("Sheet2")Count = Application.WorksheetFunction.CountIf(Worksheets("Sheet2").Range("A:A"), Me.TextBox1)If Count > 0 ThenMsgBox "Cliente já cadastrado!", vbCritical, "Cliente duplicado!"ElseiRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _    SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1'copy datas to the cellsws.Cells(iRow, 1).Value = Me.TextBox1.ValueEnd IfEnd Sub

Autocompletar com fonte de dados eu também já consigo com o código abaixo:

'Digite aqui o intervalo a ser autocompletadoPrivate Const r As String = "A:A"Private sInput As String 'Faz parar a pesquisa dos dados digitadosDim flParar As BooleanFunction RetornaLin(Sht As String, Col As String)Dim UltLinPlan As Long 'Retorna a última linha da PlanilhaUltLinPlan = Sheets(Sht).Range("A:A").End(xlDown).Row 'Retorna a linha na planilhaRetornaLin = Sheets(Sht).Range(Col & UltLinPlan).End(xlUp).Offset(1, 0).Row End Function  Sub CopiaLinhas()'Uliliza a função criada para buscar a linha para inserçãoDim Lin As Long 'Busca primeira linha disponível da plan1 na coluna ALin = RetornaLin("Sheet1", "A") 'copia o intervalo A5:Z5 para a linha retornada pela funçãoSheets("Sheet2").Range("A:A").End(xlDown).Row.Copy Sheet1.Range("A" & Lin) End Sub'Ao digitar deletar ou backspace o sistema limpa a variável de controle para pesquisar novamentePrivate Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)     'Limpa a variável de controle    If (KeyCode = vbKeyBack) Or (KeyCode = vbKeyDelete) Then        flParar = True    Else        flParar = False    End If     If (KeyCode = 13) Then        ActiveCell.Value = UserForm1.TextBox1.Text        UserForm1.TextBox1.Value = vbNullString        UserForm1.Hide    End If End Sub 'Faz a busca das palavrasPrivate Sub TextBox1_change()    Dim lPalavra As String        If flParar Then        flParar = False    Else        sInput = Left(Me.TextBox1, Me.TextBox1.SelStart)        lPalavra = GetFirstCloserWord(sInput)        If lPalavra & "" <> "" Then            flParar = True            Me.TextBox1.Text = lPalavra            Me.TextBox1.SelStart = Len(sInput)            Me.TextBox1.SelLength = 999999        End If    End IfEnd Sub'Seleciona a primeira letraPrivate Function GetFirstCloserWord(ByVal Word As String) As String    Dim c As Range        For Each c In Sheet2.Range(r).Cells    If LCase(c.Value) Like LCase(Word & "*") Then            GetFirstCloserWord = c.Value            Exit Function                                End If    Next c    Set c = Nothing End Function

A minha necessidade é: juntar tudo rs 

 

Preciso:

 

Colocar o código de pegar dados de um arquivo excel fechado e colocar como a fonte de dados do Autocompletar

 

Ter um código para adicionar informação de um destino (arquivo excel aberto) para a origem (arquivo excel fechado) - Esse eu ainda não encontrei

 

Adicionar a nova informação no arquivo com o nome dos clientes sem que haja repetição (isso eu já consegui mas quando o nome dos clientes está no mesmo arquivo que o relatório, e eu preciso que seja em arquivos separados e com o arquivo de nome de clientes fechado).

 

Adicionar a nova informação também no arquivo do relatório (ao mesmo tempo) - isso eu ainda não consegui.

 

Espero que tenha conseguido explicar melhor.

Esse é a solução que trará mais produtividade, eficiência e eficácia ao trabalho que temos hoje em dia em emitir esses relatórios.

 

Muito obrigada pela ajuda de vocês!!

[Fernanda Sanches]

Boa tarde,

 

Após muitas tentativas consegui fazer o que eu queria.

 

Vou deixar o código aqui caso alguém um dia precise.

 

Muito obrigada pela ajuda!

 

Em "ThisWorkbook" do arquivo onde está o relatório colar o código abaixo:

 

Ao abrir o arquivo do relatório automaticamente irá abrir o arquivo onde estão os dados.

Algumas funções só funcionam com o arquivo de dados aberto.

 

Ao fechar o arquivo do relatório automaticamente irá salvar e fechar o arquivo de dados. 

Private Sub Workbook_Open()Workbooks.Open ("C:\Users\fernanda.rocha\Desktop\banco de dados.xlsx")Workbooks("relatório").ActivateEnd SubPrivate Sub Workbook_BeforeClose(Cancel As Boolean)Workbooks("banco de dados").Close savechanges:=True 'salvar TrueEnd Sub

No formulário criado para a busca dos nomes de clientes colocar o código abaixo no TextBox:

 

Na pesquisa de nomes mesmo desabilitando algumas funções ainda fica meio lento quando você digita um nome diferente do que está no banco de dados. Estou tentando fazer esta parte ficar mais rápida para que essa demora não vire um problema ao fazer relatório. Se vocês tiverem alguma ideia de como fazer isso, por favor, me informem. 

Option ExplicitPrivate sInput As StringDim lPalavra As StringDim sDado As StringDim flParar As BooleanDim iRow As LongDim sCaminho As StringDim sPastaDeTrabalho As StringDim sPlanilha As StringDim sEndereço As String Function ObterDadoExterno()    'É necessário que o caminho termine com uma \    If Right(sCaminho, 1) <> "\" Then        sCaminho = sCaminho & "\"    End If        sDado = "'" & sCaminho & "[" & sPastaDeTrabalho & "]" & _      sPlanilha & "'!" & ThisWorkbook.Sheets(1).Range(sEndereço).Address(, , xlR1C1)        ObterDadoExterno = ExecuteExcel4Macro(sDado)    End FunctionFunction ObterDadoExterno2()                'É necessário que o caminho termine com uma \    If Right(sCaminho, 1) <> "\" Then        sCaminho = sCaminho & "\"    End IfEnd Function'Ao digitar deletar ou backspace o sistema limpa a variável de controle para pesquisar novamentePrivate Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)     'Limpa a variável de controle    If (KeyCode = vbKeyBack) Or (KeyCode = vbKeyDelete) Then        flParar = True    Else        flParar = False    End If     If (KeyCode = 13) Then        ActiveCell.Value = UserForm1.TextBox1.Text        UserForm1.TextBox1.Value = vbNullString        UserForm1.Hide    End If End Sub 'Faz a busca das palavrasPrivate Sub TextBox1_change()          If flParar Then        flParar = False    Else        sInput = Left(Me.TextBox1, Me.TextBox1.SelStart)        lPalavra = GetFirstCloserWord(sInput)        If lPalavra & "" <> "" Then            flParar = True            Me.TextBox1.Text = lPalavra            Me.TextBox1.SelStart = Len(sInput)            Me.TextBox1.SelLength = 999999        End If    End IfEnd Sub'Seleciona a primeira letraPrivate Function GetFirstCloserWord(ByVal Word As String) As String        Application.Calculation = xlCalculationManual  Application.ScreenUpdating = False  Application.EnableEvents = False    Dim c As Range             sCaminho = ThisWorkbook.Path    sPastaDeTrabalho = "banco de dados.xlsx"    sPlanilha = "banco de dados"    sEndereço = "A:A"        For Each c In Workbooks("banco de dados.xlsx").Sheets("banco de dados").Range("A:A").CellsIf LCase(c.Value) Like LCase(Word & "*") Then            GetFirstCloserWord = c.Value            Exit Function                          End IfNext c    Set c = Nothing     Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.EnableEvents = True End Function

No botão "Adicionar Novo" colar o código abaixo:

Private Sub CommandButton1_Click()Application.Calculation = xlCalculationManual  Application.ScreenUpdating = False  Application.EnableEvents = FalseDim iRow As LongDim iRow2 As LongsCaminho = ThisWorkbook.Path    sPastaDeTrabalho = "banco de dados.xlsx"    sPlanilha = "banco de dados"    sEndereço = "A:A"                    Dim wb As Workbook   Set wb = Workbooks("banco de dados")           Dim b As Integer        b = Application.WorksheetFunction.CountIf(wb.Sheets("banco de dados").Range("A:A"), Me.TextBox1.Value)If b > 0 ThenMsgBox "Cliente já cadastrado!", vbCritical, "Cliente duplicado!"End IfiRow = Workbooks("banco de dados").Sheets("banco de dados").Cells.Find(What:="*", SearchOrder:=xlRows, _    SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1    iRow2 = Workbooks("relatório").Sheets("Sheet1").Cells.Find(What:="*", SearchOrder:=xlRows, _      SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1   Workbooks("banco de dados").Sheets("banco de dados").Cells(iRow, 1).Value = Me.TextBox1.Value   Workbooks("relatório").Sheets("Sheet1").Cells(iRow2, 1).Value = Me.TextBox1.Value    'Clean fields TextBox to insert new datasMe.TextBox1.Value = ""Application.Calculation = xlCalculationAutomaticApplication.ScreenUpdating = TrueApplication.EnableEvents = True             End Sub