Martti

@Midori Mais uma vez, muito agradecido pela solução.

Olá senhores.

Tenho um formulario(UserForm1) no Excel com 14 textbox(txt1 até txt14) e um botão Gerar Documento.

Ao clicar no botão btnGerarDocumento, deve abrir um documento na rede( \\caminho\para\sua\pasta\AIF.docx), documento este que possui

14 Campos de Texto(Controle de Formulario), preencher de Campo1 até Campo14 com as informações do UserForm1, na mesma ordem.

Estou com erro em .ActiveDocument.Close (SalvarDocumento) e não consigo resolver.

Agradeço desde já pela ajuda.

Option Explicit

Private ObjWord As Object
Private ObjDocument As Object

Private Function AbrirDocumentoWord(NomeArquivoWordModelo As String) As Boolean
    ' Invoca o Word
    Set ObjWord = CreateObject("Word.Application")
    
    ' Se ocorrer erro, prossiga (pois checarei se houve erro logo após o comando que pode ter dado problema
    On Error Resume Next
    
    ' Tenta abrir um novo documento Word a partir de um modelo
    Set ObjDocument = ObjWord.Documents.Add(NomeArquivoWordModelo, False, 0, False)
    
    ' Checa se houve erro
    If Err <> 0 Then
        ' Restaura o tratamento padrão de erros
        On Error GoTo 0
        Err = 0
        
        ' Ocorreu erro na tentativa de abertura do documento Word
        AbrirDocumentoWord = False
        
        ' Interrompe a execução desta Function
        Exit Function
    End If
            
    ' Restaura o tratamento padrão de erros
    On Error GoTo 0
    
    ' Abertura de documento Word foi bem-sucedida
    AbrirDocumentoWord = True
End Function

Private Sub PreencheCampo(NomeCampo As String, ConteudoNovo As String)
    With ObjDocument
        ' Verifica se o campo a preencher existe
        If .Bookmarks.Exists(NomeCampo) Then
            ' O campo existe
            
            ' Preenche o campo indicado
            .Bookmarks(NomeCampo).Range.Fields(1).Result.Text = ConteudoNovo
        End If
    End With
End Sub

Private Sub ExibirWord()
    ObjWord.Visible = True
End Sub

Private Sub FecharWord(SalvarDocumento As Boolean)
    ' Fecha o documento Word
    With ObjWord
        .ActiveDocument.Close (SalvarDocumento)
        .NormalTemplate.Saved = True
    End With

    ' Fecha o Word
    ObjWord.Quit
End Sub

Private Sub cmdGerarArquivoWord_Click()
    Dim NOME_ARQUIVO As String
    NOME_ARQUIVO = "\\caminho\para\sua\pasta\AIF.docx"
        
    ' Desabilita o botão de comando
    cmdGerarArquivoWord.Enabled = False
        
    ' Tenta abrir documento Word
    If Not AbrirDocumentoWord(NOME_ARQUIVO) Then
        ' Reabilita o botão de comando
        cmdGerarArquivoWord.Enabled = True
    
        ' Fecha o Word, mas sem salvar o documento
        FecharWord False
    
        ' Houve erro. Interromper execução desta Sub
        Exit Sub
    End If
            
    ' Abertura do documento Word foi bem-sucedida
            
    ' --- Preenche os campos do documento Word com os conteúdos desejados -----------------------
    '*************************************************************************************
    
    ' Exibe o Word
    ExibirWord
    
    ' Reabilita o botão de comando
    cmdGerarArquivoWord.Enabled = True

End Sub

 

UP!

Algum dos colegas poderia melhorar este código?

Funciona 90%, mas ao atingir o limite de altura da linha (255 pixels), ele não divide

o texto adicionando uma linha abaixo.

Pode ser testado na planilha deste tópico.

Agradeço desde já.

'Code generated by OpenChat 16/04/2023
Sub FormataCélulas()
    Dim cw As Double, rh As Double, cwA As Double, c As Range
    With Range("B42:AF42")
        .MergeCells = False
        cwA = .Cells(1).ColumnWidth
        For Each c In .Cells
            cw = cw + c.ColumnWidth
        Next c
        cw = cw + .Count * 0.66
'        .Cells(1).ColumnWidth = cw
        .Cells(1).WrapText = True
        .EntireRow.AutoFit
        rh = .RowHeight
        .Cells(1).ColumnWidth = cwA
        .MergeCells = True
        .RowHeight = rh
        .HorizontalAlignment = xlJustify
        .VerticalAlignment = xlJustify
    End With
End Sub

 

@Midori, obrigado pela contribuição.

Pensei nisso inicalmente, mas como a digitação de dados já é feita em formulários no excel, seria selecionar o registro no listbox e apertar um botão "Imprimir". Se não fosse esse único campo, de 20 campos, o relatório impresso já estaria em funcionamento. Aliás, sempre funcionou até então, mas foi necessário inserir este campo com a avaliação da não conformidade, que era de outro relatório.

Como já existe essa máscara de relatório pronta, com logotipo, cabeçalho etc., e há muito tempo já é utilizada com VBA, pelas boas práticas a probabilidade de erro é menor.

Foi a inserção desse campo que impactou nesse único e gigantesco problema, porque a empresa quer que continue no Excel. Manda quem pode, obedece quem tem juízo.

Já pesquisei muito, mas ainda não conseguir unir em uma macro o split, vbNewLine e Range.MergeCells.

Se alguém puder colaborar ou pensar fora da caixa, agradeço desde já.

@Midori, mais uma vez, como sempre, agradeço pela sugestão.

@Goobsegue a planilha para melhor entendimento

 

Quem puder ajudar, agradeço desde já.

 

Conformidade.zip

Salve colegas!

Já resolvi 90% do modelo de relatório pedido, mas tenho ainda uma questão pendente.

Os dados são registrados na Plan2(Base) através de um formulário padrão.

Na Plan3(Relatorio) existe um modelo de relatório, com células referenciadas por PROCV

até então fácil de preencher com dados numéricos.

Existe uma determinada célula referenciada na Plan2(Base) que tem que ser preenchida

com o texto do relatório de conformidade.

Como a altura máxima da célula é de 255 pixels, o texto não cabe nesta célula(B42) pois 

ultrapassa em muito esse tamanho.

A largura do formulário vai da coluna B até coluna AF, portanto, tenho limites laterais, mas sem limites de linhas.

Já quebrei a cabeça, então peço ajuda dos mais experientes.

Preciso de um código que insira o texto de B42 até AF42, quebre o texto, insira* uma linha

abaixo(B43:AF43), no mesmo limite lateral e assim sucessivamente, até a ultima linha do texto.

O texto varia muito de tamanho, na maioria das vezes mais de uma página, por isso tem que inserir linhas, tem campos abaixo e não posso ter espaço em branco, senão criaria um range definido, com células mescladas.

Pensei em criar um split com o próximo espaço vazio depois de 100 caracteres e jogar o texto para baixo, mas não consegui implementar o código.

Agradeço desde já a ajuda de todos.

*não pode pular linhas pois há mais campos abaixo, acaba sobrepondo os campos.

Depois de muitos testes, uma apanhado de códigos que resolveram minha necessidade.

Necessário adequação para problemas específicos.

Sub FormataCélulas()

    Application.ScreenUpdating = False

    Dim cw As Double, rh As Double, cwA As Double, c As Range
    Dim lng As Long, lastrow As Long
    
    With Range("A32:AD32")
        .MergeCells = False
        cwA = .Cells(1).ColumnWidth
        For Each c In .Cells
            cw = cw + c.ColumnWidth
        Next c
        cw = cw + .Count * 0.66
        .Cells(1).ColumnWidth = cw
        .Cells(1).wrapText = True
        .EntireRow.AutoFit
        rh = .RowHeight
        .Cells(1).ColumnWidth = cwA
        .MergeCells = True
        .RowHeight = rh
        .HorizontalAlignment = xlJustify
        .VerticalAlignment = xlJustify
    End With
'-------------------------------------------------------------------------------------------------------------------------------

For lng = lastrow To 1 Step -1
        If Rows(lng).RowHeight > 408 Then
            Rows(lng + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Rows(lng).Resize(1).Select
            Selection.RowHeight = 409
            Cells(lng, "A").Resize(1, 32).Select
            With Selection
                .HorizontalAlignment = xlGeneral
                .VerticalAlignment = xlTop
                .wrapText = True
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ReadingOrder = xlContext
                .MergeCells = True
                .ShrinkToFit = True
            End With
        End If
        If lastrow > 1 Then
            ActiveCell.Offset(-1, 0).Range("A32:AD32").Select
        End If
        lastrow = lastrow - 1

    Next
    
    Application.ScreenUpdating = True

End Sub

 

Olá Senhores! Mais uma vez recorro ao conhecimento dos colegas aqui do fórum.

No tópico anterior, este aqui, o problema foi resolvido com a colaboração dos colegas.

Porém, com implementações, o relatório ficou mais detalhado.

Por padrão, a altura de linha do Excel tem limite de 409 pontos e o texto atual de alguns

relatórios tem superado este espaço, cortando o texto.

Alguns relatórios utilizam 2 à 3 páginas

Sei que o Excel não é a melhor ferramenta para esse fim, mas é o que tem para o momento.

Se algum colega tiver ideia melhor de usar máscara de relatório ou resolver esse problema

de mais de uma linha, agradeço desde já.

Replicando o tópico original:

"A empresa utiliza uma planilha que é uma máscara de formulário, onde as células são preenchidas facilmente com as funções INDICE+CORRESP.

Porém, há um campo dinâmico, o único a ser preenchido, que não consigo resolver por VBA.

Na célula A32 deve ser digitado um relatório de conformidade e vistoria. Esse relatório pode conter de 5 à "n" linhas.

Manualmente é fácil mesclar as células, quebrar o texto e justificar o alinhamento do texto. Geralmente vai até o limite impresso do relatório, coluna T.

Devido à essa variação do número de linhas do relatório e  não poder haver linhas em branco, não consigo criar uma macro para mesclar as células, quebrar o texto e justificar o alinhamento, caso contrário seria só fixar uma range(A32:T"n") e aplicar a macro."

 

cs_modelo.zip

@Midorisem modéstia, ambas colaborações resolvem meu problema, de modos diferentes, mas atingem o mesmo propósito.

Há situações onde preciso de tabela organizada por colunas e outras situações onde só uma coluna resolve o ÍNDICE+CORRESP.

Por isso agradeço aos dois colegas por compartilharem do conhecimento, mais cebeças pensam melhor do que uma.

Hoje ou amanhã devo postar outra situação para totalizar 3 planilhas diferentes...

Começo de ano, com novas filiais e/ou terceirizados é uma tempestade de planilhas ainda sem padronização.

E não sou programador, mas a necessidade é a mãe da criatividade...

@Midori e @OreiaG muito obrigado por me auxiliarem nesse problema.

Apenas indiquei a resposta do Midori como solução porque respondeu anteriormente, mas

ambas as respostas resolvem prontamente a situação.

 

Agradeço por compratilharem vosso tempo e vosso conhecimento.

 

Bom dia senhores.

Recorro mais uma vez ao conhecimento dos colegas.

Passei a receber um arquivo em excel que foi convertido de um PDF.

Essas conversões deixa a desejar, pois muitas vezes quebram tabelas, linhas e tabulações.

O arquivo original em PDF possui 159 páginas, o que gera um arquivo .xls com 159 planilhas.

Preciso juntar todas as planilhas em uma só, em sequencia, para organizar os dados e tabelas para gerar os relatórios.

Em anexo envio um arquivo com uma situação semelhante.

Desde já agradeço pela ajuda.

 

Relacao-das-ruas-agupadas-por-bairro-em_01_12_22.zip

@OreiaGMuito obrigado por compartilhar seu tempo e seu conhecimento. Atendeu plenamente minha necessidade. 

@ScofieldgynEncaminho um modelo com dados ficitícios, mas que atende minha necessidade.

As células com margem são preenchidas através das funções ÍNDICE+CORRESP.

Na célula A42 íncia uma região dinâmica, podendo ser de 5 à "n" linhas.

Essa range tem que se auto-ajustar, delocando linhas para baixo ou para cima.

Manualmente é fácil mesclar as células, quebrar o texto e justificar o alinhamento do texto. Geralmente vai até o limite impresso do relatório, coluna AD.

Devido à essa variação do número de linhas do relatório e não poder haver linhas em branco, não consigo criar uma macro para mesclar as células, quebrar o texto e justificar o alinhamento, caso contrário seria só fixar uma range(A42:AD"n") e aplicar a macro.

Agradeço desde já a ajuda recebida.

cs_modelo.zip

@ScofieldgynPerfeitamente, já estou trabalhando nas modificações, apenas adiantei o pedido de ajuda para iniciar a discussão sobre o problema. Grato pelo seu tempo.

Olá Senhores! Mais uma vez recorro ao conhecimento dos colegas aqui do fórum.

A empresa utiliza uma planilha que é uma máscara de formulário, onde as células são preenchidas facilmente com as funções INDICE+CORRESP.

Porém, há um campo dinâmico, o único a ser preenchido, que não consigo resolver por VBA.

Na célula A32 deve ser digitado um relatório de conformidade e vistoria. Esse relatório pode conter de 5 à "n" linhas.

Manualmente é fácil mesclar as células, quebrar o texto e justificar o alinhamento do texto. Geralmente vai até o limite impresso do relatório, coluna T.

Devido à essa variação do número de linhas do relatório e  não poder haver linhas em branco, não consigo criar uma macro para mesclar as células, quebrar o texto e justificar o alinhamento, caso contrário seria só fixar uma range(A32:T"n") e aplicar a macro.

Agradeço desde já a ajuda recebida.

@AfonsoMira Boas!

Muitíssimo obrigado mais uma vez por compartilhar seu conhecimento.

Resolveu plenamente meu problema!

Salve amigos! Mais uma vez recorro ao vasto conhecimento dos integrantes desse forum.

Recebi uma planilha de um departamento e estou com problemas com a busca e referência.

Na Plan2 existem 4 colunas, K, Q, BD e BC.

A coluna K tem o nome de ROUTER1 e a coluna Q, ROUTER2, coluna BC, PASS1 e coluna BD, PASS2

A TABELAB de referência está na Plan3("REF") com 3 colunas e 668 linhas

Se a coluna K tiver informação, faz um PROCV na 2ª coluna da TABELAB e retorna o valor na coluna BC

e na 3ª coluna da TABELAB e retorna o valor na coluna BD.

Se a coluna K estiver vazia, o valor a ser considerado é o da mesma linha na coluna Q, faz um PROCV na

2ª coluna da TABELAB e retorna o valor na coluna BC e na 3ª coluna da TABELAB e retorna o valor na coluna BD.

Resumindo, havendo K & i, BC & i e BD & i serão preenchidos

Não havendo K & i, Q & i passa a ser referência, BC & i e BD & i serão preenchidos.

O código abaixo não funciona.

Quem puder compartilhar conhecimento para acertar o código, agradeço desde já.

 

Sub PASS_TEST() '***********************************************************

    Dim ROUTER1, ROUTER2, TABELAB 	As Range
    Dim ultLinha        			As Integer
    Dim resultado_procv 			As Variant
    Dim i 							As Integer
    
	Application.ScreenUpdating = False
    
    ultLinha = Sheets("Plan2").Cells(Cells.Rows.Count, 1).End(xlUp).Row
    Set TABELAB = Sheets("REF").Range("a2:c668")
    Set ROUTER1 = Sheets("Plan2").Range("K" & ultLinha)
    Set ROUTER2 = Sheets("Plan2").Range("Q" & ultLinha)
    
    Sheets("Plan2").Select
    
    For i = 2 To ultLinha
      
        If ROUTER1 <> "" Then
            ROUTER1 = Sheets("Plan2").Range("K" & i).Value
            resultado_procv = Application.VLookup(ROUTER1, TABELAB, 2, False)
            Sheets("Plan2").Range("BD" & i).Value = resultado_procv
        ElseIf ROUTER1 = "" Then
            ROUTER1 = Sheets("Plan2").Range("Q" & ultLinha).Value
            resultado_procv = Application.VLookup(Bairro2, TABELAB, 2, False)
            Sheets("Plan2").Range("BD" & i).Value = resultado_procv
        End If
        
    Next i
    
    i = i + 1
    
End Sub

 

@Midori Parabéns pela solução do problema, melhor impossível.

Vou me debruçar sobre o código para adquirir mais conhecimento.

Muito obrigado por compartilhar seu tempo e seu conhecimento.

Sua ajuda foi por demais importante...

@MidoriIsso mesmo, o status se modifica ou não a partir da atualização da linha.

Na verdade, acredito que preciso eliminar o status FINALIZADO.

A proxima data de calibração será estipulada no momento da realização da mesma***,

onde cada chefe de setor saberá se será em até 30, 60 ou 90 dias.

Como no exemplo acima, quando a importação dos dados atualizar a 3ª calibração, preencherá tb

a 4ª calibração com uma data estipulada***, o status passará a "vencerá em xx dias"

Por isso penso em tirar o status FINALIZADO, ficando só VENCIDO HÁ XX DIAS, VENCE HOJE, VENCERÁ EM XX DIAS,

porque quando a calibração é feita, a proxima calibração é preenchida***, reiniciando a contagem.

Como no exemplo, quando a 3ª calibração foi feita, o status anterior era "VENCIDO HÁ 1 DIAS" (HOJE() - 22/03/2022).

Quando a planilha foi atualizada e a data da 3ª calibração foi inserida, a data da 4ª calibração tb foi inserida(23/04/2022), então, hoje, 24/03, executando o código,

este buscará a última célula preenchida da linha, o status mudará  "VENCERÁ EM 29 DIAS".

Como no exemplo, se não houve a 3ª calibração para a linha 2, o status permanecerá "VENCIDO HÁ XX DIAS" até que o código identifique alguma data na 3ª calibração, que passará a ser a última célula com data na linha 2.

Assim penso em somente 3 status, à medida que as calibrações forem sendo atualizadas.

Coloco-me à disposição para esclarecimentos.

Obrigado pelo seu tempo.

 

***defini essa mudança com a chefia por me parecer mais objetiva, visto a volatilidade das datas.

No meu analfabetismo em variáveis, pensei neste conceito:

 

Sub Status()
Dim Linha As Double
Linha = 1

Dim ColunaStatus    As Double
Dim ColunaData      As Double
Dim ultimalinha     As Long
Dim lin             As Long

ultimalinha = Range("A" & Rows.count).End(xlUp).Row
For lin = 2 To ultimalinha

ColunaStatus = 9
ColunaData = Range("J" & lin).End(xlToRight).Column

With Plan1

    Do
    
        Linha = Linha + 1
.
.
.
.
.
.
End Sub

 

@Midori Isso mesmo, excelente entendimento!

Sempre que as datas forem atualizadas(importadas), a mudança de status deve ser feita pela ultima celula preenchida na linha + 1( penultima e ultima).

Se a ultima celula preenchida for <>"", então:

 If ultima<Hoje = Status =Vencida à & Hoje-ultima & dias

If ultima=Hoje = Status = Vence Hoje

If ultima>Hoje = Status = Vencerá em & ultima-Hoje & dias

Else

OK (preciso melhorar isso, aceito sugestões)

Um detalhe é que as maquinas tem períodos de calibração diferentes, não sendo possível fixar que calibração 2 será calibração 1 + 30 (ou 60, 90) dias.

O status mudará sempre que houver acréscimo de calibração.

Agradeço pelo seu tempo.

 

@Midori

Desculpe a falha

calibracao.zip

@Midori

Obrigado pela atenção.

No VBE tem um módulo com o código que eu utilizava anteriormente.

Em virtude de mudanças administrativas, a planilha teve que ser alterada.

O código compara a coluna J com a coluna K e atualiza o status na coluna I.

Na medida que as calibrações são efetuadas, os registros avançam nas colunas,

então, no exemplo, a proxima calibração(colunaL) deverá ser comparada com

a coluna anterior(coluna K) e assim por diante.

Sim, poderia usar formulas e até formatação condicional por cores, mas obrigatoriamente

tem que ser em VBA.

Grato pelo seu tempo.

Salve amigos! Mais uma vez recorro ao vasto conhecimento dos integrantes desse forum.

Em anexo uma planilha de agendamento de calibração de instrumentos.

O código é adaptado de uma outra planilha, mas com um range de 2 colunas

Preciso que localize a última célula preenchida da linha e execute o código.

Os dados da coluna 1ª Calibração até 10ª Calibração são importados de outra planilha,

Só preciso atualizar o status à cada importação, porém o período de calibração de

cada máquina é diferente e são incrementais.

Consegui resolver para a primeira coluna, mas meu conhecimento me limita a este ponto.

Quem puder ajudar, agradeço desde já.

Abs

calibracao.zip

Amigos, resolvi quase a totalidade do problema mas necessito de ajuda para melhorar o código abaixo para aparecer a ListRow de 10 linhas?

Private Sub ComboBox11_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Dim arrIn As Variant, arrOut As Variant
    Dim i As Long, j As Long

    arrIn = Plan6.Range("log")

    ReDim arrOut(1 To UBound(arrIn), 1 To 1)

    For i = 1 To UBound(arrIn)
        If arrIn(i, 1) Like "*" & ComboBox11.Text & "*" Then
            j = j + 1
            arrOut(j, 1) = arrIn(i, 1)
        End If
    Next
    ComboBox11.List = arrOut
End Sub

 

Salve amigos!

Mais uma vez recorro ao vasto conhecimento dos integrantes desse forum.

Tenho uma ComboBox no formulário que é populado por um identificador alfanumérico que é uma sequência de outras TextBox.

Como são várias origens, este identificador possui 15 caracteres, porém em sequências diferentes.

Por exempo, RBP1578F2TRN830, GRU18CNF1235745, etc.

O identificador pode começar com letra ou número.

Nexta ComboBox, preciso da função autocompletar por qualquer parte do texto da RowSource, não pelas iniciais, pois

pesquisando uma sequência de letras ou números em qualquer posição eu reduzo muito o universo da pesquisa.

Exempo: Pedro, José e Manoel. Se eu digitar a letra "e" aparecem 3 nomes, mas digitando a letra "s" aparece só José.

Quando era planilha eu conseguia com o código abaixo, mas no formulário já vai além do meu conhecimento.

Desde já agradeço a ajuda de todos.

'---------------------------------------------------------------------------------------
' Module    : UserForm1
' Author    : MVP, Sergio Alejandro Campos
' Date      : 19/02/2016
' Purpose   : Búsqueda "as type"
'---------------------------------------------------------------------------------------

'1)Al iniciar
Private Sub UserForm_Initialize()
    Me.Height = 181
End Sub

'2)Al escribir texto en el TextBox
Private Sub TextBox1_Change()

TextBox1.Text = UCase(TextBox1.Text)

TextBox1.SelStart = Len(TextBox1)

    If Me.TextBox1.Value = "" Or Me.TextBox1.Value = " " Then
        Me.Height = 181

    Else
        Me.Height = 181
        Dim rng As Range, e
        Set Lista = Range("lstProdutos")
        With Me
            .ListBox1.Clear

            For Each i In Lista.Value
                If (i <> "") * (i Like "*" & .TextBox1.Value & "*") Then
                    .ListBox1.AddItem i
                End If
            Next i

        End With
    End If
End Sub

'3)Aceptar el valor elegido y capturarlo en la celda activa
Private Sub CommandButton2_Click()
    Cuenta = Me.ListBox1.ListCount

    For i = 0 To Cuenta - 1

        If Me.ListBox1.Selected(i) = True Then
            ActiveCell.Value = Me.ListBox1.List(i)
        End If

    Next i
    Unload Me

End Sub

'4)Cerrar el formulario
Private Sub CommandButton1_Click()
    Unload Me
End Sub
Private Sub Listbox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  With Me.ListBox1
    For i = 0 To .ListCount - 1
      If .Selected(i) Then
        ActiveCell.Value = .List(i, 0)
        Exit For
      End If
    Next
  End With
    Unload Me
End Sub

-----Modulo--------
Private Sub Listbox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  With Me.ListBox1
    For i = 0 To .ListCount - 1
      If .Selected(i) Then
        Me.TextBox1.Value = .List(i, 0)
        Exit For
      End If
    Next
  End With

End Sub