Midori

@Revolucao A dificuldade em colocar o código no módulo correto deve ser porque falta conhecer um pouco mais os componentes do editor do VBA. Veja que no print que você postou no canto esquerdo tem o explorador de projeto "Projeto - VBAProject". Lá é onde fica a hierarquia dos projetos das suas planilhas e os elementos de cada um. Entre eles estão os módulos e para editar um código em qualquer um é com clique duplo. No caso da sua planilha eles estão em VBAProject (Vendas pacote.xlsm) e lá tem estas duas ramificações (ou pastas): Microsoft Excel Objetos: Aí tem os módulos Workbook (EstaPastaDeTrabalho) e Sheet (Cad_Prod e Mov_Venda). Cada planilha que você cria terá um módulo associado a ela. E nesses módulos é onde devem ficar os procedimentos que são ativados por evento como o Change que postei. Módulos: Aí ficam os módulos que alguns chamam de Standard e que podem ser adicionados em Inserir > Módulo. Além desses também tem Class e Form.

@Revolucao Faltou colar a outra função ProcuraComentario como demonstrado no print.

@Revolucao Colou no módulo errado. Veja que comentei acima que tem que ser no módulo Mov_Venda (está selecionado no print) e não no Módulo5.

@Revolucao Colou em Mov_Venda como demonstrado no print? Se fez isso e digitou um código válido na coluna Cód_Produto da planilha Mov_Venda o comentário vai aparecer na coluna ao lado...

@Alexandre José Costa Antes de atualizar os valores o Calculate pode desativar os eventos com EnableEvents, veja se assim resolve o problema do travamento, Private Sub Worksheet_Calculate() Dim Valor As Range Application.EnableEvents = False For Each Valor In [D3:D71] If Not IsError(Valor) Then If Valor.Value <> "" Then Call Atualiza(Valor, 5) End If End If Next Valor Application.EnableEvents = True End Sub Se ainda não resolver e se acha que o problema pode ser a taxa de atualização você pode tentar modificar isso com ThrottleInterval (Application.RTD.ThrottleInterval). Nas documentações diz que o intervalo de atualização do RTD é a cada 2 segundos. https://docs.microsoft.com/en-us/office/vba/api/excel.rtd.throttleinterval

@Revolucao Não é para usar a fórmula como comentei no primeiro post. Cole as macros no módulo, assim o comentário será adicionado quando digitar o código na planilha,

@Revolucao Para adicionar o comentário, a macro do Change fica assim, Private Sub Worksheet_Change(ByVal Target As Range) If Not [Tab_Vendas].ListObject.DataBodyRange Is Nothing Then If Application.Intersect( _ Target, [Tab_Vendas].ListObject.ListColumns("Cód_Produto").DataBodyRange) Then Dim Comentario As String Comentario = ProcuraComentario(Target, _ [Tab_Produto].ListObject.ListColumns("Sequencia").Range, 2) If Not Target.Offset(0, 1).Comment Is Nothing Then Target.Offset(0, 1).Comment.Delete End If If Comentario <> "" Then Call Target.Offset(0, 1).AddComment(Comentario) End If End If End If End Sub Ai também usei a função ProcuraComentario que postei no post anterior. Antes da adição do comentário a macro verifica se já existe algum na célula ao lado. Caso exista ele será substituído pelo da busca ou apenas removido caso o código não exista.

@daluque Pegando o caminho da planilha pode ser assim, Sub CriaSubPastas() Dim Pasta As Range For Each Pasta In [A6:A29] If Pasta <> "" Then If Dir(Pasta, vbDirectory) <> "" Then Dim Novo As String Dim I As Integer For I = 1 To 6 Novo = Pasta & "\NovaPasta" & I If Dir(Novo, vbDirectory) = "" Then Call MkDir(Novo) End If Next I End If End If Next Pasta End Sub

@daluque Assim teria que fazer um loop na lista de diretórios da planilha em vez da forma que fiz com For Each. Mas se esse é só um exemplo e a quantidade vai de 1 até 1100 mesmo é melhor fazer um For de 1 até 1100.

@Revolucao Os comentários foram acrescentados, mas a formatação da sua tabela ocultou. Se aumentar o tamanho da linha eles vão aparecer.

@daluque Se o diretório for outro é só editar o argumento de GetFolder. Sub CriaSubPastas() Dim Fso As Object Dim Pasta As Object Set Fso = CreateObject("Scripting.FileSystemObject") For Each Pasta In Fso.GetFolder("C:\DiretorioDeCasos\").SubFolders If Left(Pasta.Name, Len("Caso1")) = "Caso1" Then Dim Novo As String Dim I As Integer For I = 1 To 6 Novo = Pasta.Path & "\subcaso" & I If Not Fso.FolderExists(Novo) Then Call Fso.CreateFolder(Novo) End If Next I End If Next Pasta End Sub Obs: A macro vai criar os subdiretórios em todas as pastas que começam com Caso1

@Revolucao Veja se assim resolve, Function ProcuraComentario(Valor As Range, Area As Range, Deslocamento As Integer) As String Dim Celula As Range Set Celula = Area.Columns(1).Find( _ What:=Valor.Value, LookIn:=xlValues, LookAt:=xlWhole) If Not Celula Is Nothing Then Set Celula = Celula.Columns(Deslocamento) If Not Celula.Comment Is Nothing Then ProcuraComentario = Celula.Comment.Text End If End If End Function E na célula entre com o nome da fórmula, p.ex, =PROCURACOMENTARIO(Tab_Vendas[@[Cód_Produto]];COD_produto;2)

@AlexAltheman Agora é só deixar as células da tabela com essas formatações. Antes não era possível porque o formulário escrevia no formato texto, mas agora no numérico você pode aplicar.

@Alexandre José Costa Se os testes rodaram sem erro então a sua planilha pode estar corrompida (você comentou que ficou assim após um fechamento repentino). Se for isso talvez seja possível reparar, mas acho melhor criar outra do zero ou pegar algum backup. Arquivos xls também aceitam macros, mas se preferir pode deixar um arquivo só para atualizar o RTD e outro com a macro. Dependendo da quantidade de Loops em um procedimento, a planilha pode deixar de responder. Normalmente a função DoEvents resolve esses casos, mas só testando a planilha real para entender se isso é necessário e adequado para o caso.

@AlexAltheman Para salvar como valor use a propriedade Value do TextBox, p.ex, .Cells(lLinha, 10).Value = frmCliente.txtdolar.Value .Cells(lLinha, 11).Value = frmCliente.txteuro.Value .Cells(lLinha, 12).Value = frmCliente.txtcusto.Value ... Sobre copiar os dados para o formulário, a Sub lsPreencher faz isso no DoubleClick.

@Alexandre José Costa Feche esse arquivo e crie uma nova planilha (do zero), coloque apenas um link RTD (célula A1 por exemplo) e teste a macro. O Calculate vai ficar assim, Private Sub Worksheet_Calculate() Dim Valor As Range Set Valor = [A1] If Not IsError(Valor) Then If Valor.Value <> "" Then Call Atualiza(Valor, 5) End If End If End Sub Se atualizar as colunas sem erro, coloque mais links nessa planilha de teste (5 p.ex), Private Sub Worksheet_Calculate() Dim Valor As Range For Each Valor In [A1:A5] If Not IsError(Valor) Then If Valor.Value <> "" Then Call Atualiza(Valor, 5) End If End If Next Valor End Sub Veja se ocorre algum erro nesses testes. A Sub Atualiza é a última que postei.

@Alexandre José Costa Tem alguma célula mesclada? Se tiver remova a mescla. Caso não seja isso talvez a planilha esteja tirando a referência do comando copy.

@Alexandre José Costa Fiz outras alterações nas duas Subs. Testei e atualizou corretamente. Private Sub Worksheet_Calculate() Dim Valor As Range For Each Valor In [D3:D71] If Not IsError(Valor) Then If Valor.Value <> "" Then Call Atualiza(Valor, 5) End If End If Next Valor End Sub Sub Atualiza(Atual As Range, Colunas As Integer) Dim Sequencia As Range Dim Conta As Integer If Colunas < 2 Then Exit Sub Set Sequencia = Atual.Offset(0, 1).Resize(1, Colunas - 1) Conta = WorksheetFunction.CountA(Sequencia) If Atual.Value <> Atual.Offset(0, 1).Value Then If Conta > 0 Then Set Sequencia = Atual.Offset(0, 1).Resize(1, Conta) If Conta < Colunas Then Call Sequencia.Copy(Sequencia.Offset(0, 1)) Else Call Sequencia.Resize(1, Conta - 1).Copy(Sequencia.Offset(0, 1)) End If End If Atual.Offset(0, 1).Value = Atual.Value End If End Sub

Editei a macro, veja se copiou o código atualizado.

@Alexandre José Costa Como alternativa você pode testar esta Sub que modifiquei para usar Copy/Paste no lugar do Loop. Assim fica mais rápido, Sub Atualiza(Atual As Range, Colunas As Integer) Dim Sequencia As Range Dim Conta As Integer Set Sequencia = Atual.Offset(0, 1).Resize(1, Colunas) Conta = WorksheetFunction.CountA(Sequencia) If Atual.Value <> Atual.Offset(0, 1).Value Then Set Sequencia = Atual.Offset(0, 1).Resize(1, IIf(Conta = 0, 1, Conta)) If Conta = Colunas Then Call Sequencia.Resize(1, Conta - 1).Copy(Sequencia.Offset(0, 1)) Else Call Sequencia.Copy(Sequencia.Offset(0, 1)) End If Atual.Offset(0, 1).Value = Atual.Value End If End Sub

@Alexandre José Costa Sem o arquivo fica difícil sugerir algo. A planilha tem muitas fórmulas e leva tempo para calcular? O link RTD com a planilha está ok? Pode ser questão de processamento. Tente criar outro arquivo do zero com a macro só para ver se acontece o mesmo.

Não uso o Codeblocks, mas no manual onde fala sobre code folding pode te ajudar a configurar, https://www.codeblocks.org/docs/main_codeblocks_en3.html

@wesley.elias Se o documento está conectado a um banco de dados faça um loop na quantidade de registros e pegue o nome do funcionário com DataFields. Aí é só ir salvando com ExportAsFixedFormat.

@josequali Antes de adicionar no combo verifique se o produto não é nulo, Do Until rs.EOF If Not IsNull(rs!Produto) Then Me.filtro2.AddItem rs!Produto End If rs.MoveNext Loop

@Flávia de Oliveira Batista O código modificado para executar a partir do Excel. Deixe o Outlook aberto antes de rodar e ative as referências Microsoft Outlook e Word na planilha. Sub ImportTableToExcel() Dim xOutlook As New Outlook.Application Dim xMailItem As MailItem Dim xTable As Word.Table Dim xDoc As Word.Document Dim xWs As Worksheet Dim I As Integer Dim xRow As Integer On Error Resume Next Set xWs = ThisWorkbook.ActiveSheet xRow = 1 For Each xMailItem In xOutlook.Application.ActiveExplorer.Selection Set xDoc = xMailItem.GetInspector.WordEditor For I = 1 To xDoc.Tables.Count Set xTable = xDoc.Tables(I) xTable.Range.Copy xWs.Paste xRow = xRow + xTable.Rows.Count + 1 xWs.Range("A" & CStr(xRow)).Select Next Next End Sub