Este fórum está sendo desativado

[SandroLima]

Boa noite, usuários e colaboradores do fórum.

Gostaria de pedir ajuda de vcs para fazer um "upgrade" em uma macro que possuo de "Parcelamento".

A macro de parcelamento está inserida no botão "Parcelamento Atual" e funciona perfeitamente.

A macro com as mudanças que estou tentando implementar associei ao botão "Parcelamento Modificado"

Consegui com que ela funcionasse parcialmente apenas...

O que gostaria que a macro modificada fizesse de novidade:
1) Que na InputBox que pergunta o Nº de Registro para o qual se deseja fazer o parcelamento que ela já trouxesse a informação do registro cuja linha da tabela está selecionada.
Por exemplo a linha em que se encontra o paciente "Basílio" é a de registro número 10 e que então a inputbox trouxesse essa informação caso qualquer célula dessa linha estivesse selecionada. E que o número informado na Inputbox estivesse selecionado (destacado) para facilitar a alteração caso necessário.

2) Não sei se isso é possível mas também é desejado que caso o valor da célula que contem o número de parcelas seja "" (vazio) ou "-" que na mesma inputbox ele tenha o campo para inserir a quantidade de parcelas. Caso isso não seja possível que ele abra então uma segunda inputbox para informar a quantidade de parcelas.
A primeira Inputbox continua sendo a que pergunta o nº do Registro a ser alterado.

3) As novas linhas inseridas deverão ser sempre acima daquela que deu origem ao parcelamento.
Na sequencia... Parcela 1 de 3, Parcela 2 de 3, parcela 3 de 3...
Assim como na macro atual.. porém ela só funciona quando a linha que origina o parcelamento encontra-se no topo da tabela.

Poderiam me ajudar com isso?

Segue a planilha anexa para testes.

Nela estão as duas Macros.
A macro "Parcelamento Atual" funciona adequadamente mas apenas quando o registro em questão encontra-se na primeira linha da tabela.
E a Macro "Parcelamento Modificado" que tentei fazer o esboço funciona parcialmente.

Obrigado a quem puder colaborar.

[SandroLima]

Boa tarde...

Alguém tem sugestões para ajudar na melhoria?

[SandroLima]

Boa tarde.

Alguém sabe se é possível esse tipo de melhoria? Poderiam me ajudar?

[babdallas]

Faça o seguinte por favor: explique com detalhes e exemplos como deve ser a inserção dos dados de parcelamento e de onde os dados são provenientes.
Baseado na sua explicação, prefiro fazer uma macro do zero para que atenda a sua necessidade do que ficar adaptando a antiga.

[SandroLima]

Boa tarde, babdallas.

Vamos lá.

A Macro atual me atende bem mas queria deixá-la ainda melhor.

Ela faz o passo a passo que preciso a partir da 1ª linha da tabela:
- Insere a quantidade de linhas conforme o valor da coluna [Qtde Parcelas]
- Copia os dados da linha primária ou linha base para as demais linhas inseridas
- Faz a distinção das novas linhas inseridas na coluna [Competência] inserindo valores com a discriminação da parcela (Parcela 1 de 5, Parcela 2 de 5 e assim sucessivamente...)

O grande porém da macro é que ela só funciona se a linha que eu quero realizar o parcelamento estiver na 1ª posição do corpo da tabela.

A macro com as mudanças que estou tentando implementar associei ao botão "Parcelamento Modificado"

Iniciei o código dela baseado em uma outra macro que possuo para outra finalidade.

Com a nova macro eu gostaria:
1) Fosse aberta uma InputBox na qual será inserido o Nº do Registro da linha para a qual se deseja apontar a Macro

2) Que na InputBox já venha nativo o valor do Registro da linha que está selecionada.
Em nosso exemplo prático suponhamos que qualquer célula da linha com o Nº da coluna {Registro] igual a "10" (linha para qual desejo realizar o parcelamento) esteja selecionada.
Por exemplo estou com a célula com o valor "Suzana Gonçaves Braga" (G15) ou com o valor "2000" (J15) selecionadas... enfim qualquer célula da linha de Registro 10 que é a que desejo para realizar o parcelamento.

Ao clicar no botão da Macro ela abre uma InputBox já trazendo o valor "10" (que é a linha cuja alguma célula está selecionada e para a qual desejo fazer o parcelamento).
O valor dentro da Inpubox já deve vir preenchido com o valor "10" de maneira que possa ser editável ao digitar outro valor sem a necessidade de apagar o valor usando o backspace (valor selecionado pelo cursor).
Esqueci o termo que se fala agora... o 10 já viria selecionado para eu possa digitar outro valor (caso queira) sem a necessidade de apertar o backspace e apagar o "10" antes de digitar outro valor. Apenas para facilitar a alteração casso desejada.

3) Se for possível é desejado que caso o valor da célula na coluna [Qtde Parcelas] seja "" (vazio) ou "-" que na mesma inputbox ele tenha o campo para inserir a quantidade de parcelas.
Caso isso não seja possível que ele abra então uma segunda inputbox para que seja informada a quantidade de parcelas.

4) A linha que deu origem ao parcelamento deve ser deslocada para o Topo da Tabela (vide Planilha "RESULTADO DESEJADO INICIAL")
As novas linhas inseridas deverão ser sempre acima daquela que deu origem ao parcelamento.
Na sequencia... Parcela 1 de 3, Parcela 2 de 3, parcela 3 de 3...

Inseri a Planilha "RESULTADO DESEJADO FINAL" para mostrar o resultado desejado

Segue a planilha anexa com o resultado desejado para testes.

[SandroLima]

Boa tarde, pessoal.

Alguém tem sugestões de melhoria para a macro?

[Raygsson]

A sua demanda esta muito grande, muita gente nem vai ler.
Tenta abrir tópicos menores, fazer os ajustes por partes.
Talvez assim consiga ajuda.

Att,
Raygsson

[SandroLima]

Bom dia.

Alguém poderia me ajudar a melhorar a macro?

[AfonsoMira]

Boas estive a dar uma olha e por enquanto apenas consegui fazer com que o input box traga o valor "Padrão".

Código:

Código: Selecionar todos

Sub Parcelamento_Modificado()
    
    Dim Plan As Worksheet
    Dim Tabela As ListObject
    Dim Col_Zero As Long, Col_Reg As Long
    Dim NRegistro As Integer
    Dim CodRecibo As Variant, Matriz() As Variant, Erro As Variant
    Dim Counter As Long, Linha As Long, ColRecibo As Long
    Dim valor As Double
    Dim X As Long
    Dim valorPadrao As Long
    
    Set Plan = Wsh_AtivDiarias
    Set Tabela = Plan.ListObjects("TB_AtivDiarias")
    
    Matriz = Tabela.DataBodyRange.Value
    Col_Zero = Tabela.DataBodyRange.Range("A1").Column - 1
    Col_Reg = Tabela.ListColumns("Registro").DataBodyRange.Column - Col_Zero
    
    If IsNumeric(Cells(ActiveCell.Row, 2)) Then
    valorPadrao = Cells(ActiveCell.Row, 2).Value
    End If
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    Do
        On Error GoTo ErroLocaliza
        
        NRegistro = InputBox("Informe o Nº do Registro para realizar o parcelamento", "PARCELAMENTO", valorPadrao)
        
        For Linha = LBound(Matriz, 1) To UBound(Matriz, 1)
        
            If Matriz(Linha, Col_Reg) = NRegistro Then 'Se o registro existir...
    
                Tabela.ListColumns("Competência").DataBodyRange.Cells(1, 1).Value = "Parcela " & 1 & " de " & _
        Tabela.ListColumns("Qtde Parcelas").DataBodyRange.Cells(1, 1).Value
    
                On Error Resume Next
                For X = 2 To Tabela.ListColumns("Qtde Parcelas").DataBodyRange.Cells(1, 1).Value
                    Tabela.ListRows.Add (1), alwaysinsert:=True
                    Tabela.ListRows(2).Range.Copy
                    Tabela.ListRows(1).Range.PasteSpecial xlPasteAllUsingSourceTheme, Operation:=xlNone _
                        , SkipBlanks:=False, Transpose:=False
                    Tabela.ListColumns("Registro").DataBodyRange.Cells(1, 1).Value = _
                        Tabela.ListColumns("Registro").DataBodyRange.Cells(1, 1).Value + 1
                    Tabela.ListColumns("Competência").DataBodyRange.Cells(1, 1).Value = "Parcela " & X & " de " & _
                        Tabela.ListColumns("Qtde Parcelas").DataBodyRange.Cells(1, 1).Value
            
                    If Tabela.ListColumns("Item").DataBodyRange.Cells(1, 1).Value = "Paciente" Then
                        Tabela.ListColumns("Status Recibo / NF").DataBodyRange.Cells(1, 1).Value = ""
                    Else
                    
                    End If
                Next
            
                Counter = Counter + 1
                
                Exit For
                
            End If
        
        Next Linha
        
        If Linha = 0 Or Linha = UBound(Matriz, 1) + 1 Then
            
            MsgBox "Registro não encontrado" & vbCrLf & vbCrLf & NRegistro
            
        Else
        
            Erase Matriz
            
            Wsh_AtivDiarias.Activate
            
            Exit Do
            
        End If
        
    Loop
    
    Set Tabela = Nothing
    Set Plan = Nothing
    
    If 1 = 2 Then

ErroLocaliza:
    Erro = Err
    
    MsgBox "Ocorreu o erro " & Erro & ". Verifique!"
    
    Application.ScreenUpdating = True
    
    End If
    
End Sub

Vou tentar fazer as outras questões que colocou.

[AfonsoMira]

Boas veja se é este o resultado que deseja.

Corri a macro e fiz a comparação com o ficheiro que envio na aba "RESULTADO DESEJADO FINAL" e ficou igualzinho.

Código:

Código: Selecionar todos

Sub parcelar()

Dim valorPadrao As Long
Dim i As Long
Dim Tabela As ListObject
Dim NRegistro As Long
Dim maximo As Double
Dim UltimaLinha As Long
Dim Linha As Long
Dim qtd_parcela As Integer
Dim linhaTabela As Long
Dim x As Long

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With


Set Tabela = ActiveSheet.ListObjects("TB_AtivDiarias234")

If IsNumeric(Cells(ActiveCell.Row, 2)) Then
    valorPadrao = Cells(ActiveCell.Row, 2).Value
End If

NRegistro = InputBox("Informe o Nº do Registro para realizar o parcelamento", "PARCELAMENTO", valorPadrao)

If NRegistro = 0 Then
MsgBox "Insira um valor!", vbOKOnly
Exit Sub
End If

UltimaLinha = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row

Linha = 0

For i = 12 To UltimaLinha

    If Cells(i, 2).Value = NRegistro Then
        Linha = i
        i = i + UltimaLinha
    End If
    
Next i

If Linha = 0 Then
    MsgBox ("Nº de Registro não encontrado!")
    Exit Sub
End If

If Cells(Linha, 11).Value = "" Or Cells(Linha, 11).Value = "-" Then

    qtd_parcela = InputBox("Informe a quantiade de parcelas", "PARCELAS", 1)
    
    Cells(Linha, 11).Value = qtd_parcela
    
End If


Cells(Linha, 13).Value = "Parcela " & 1 & " de " & Cells(Linha, 11).Value

linhaTabela = Linha - 11

For x = 2 To Cells(Linha, 11).Value

Tabela.ListRows.Add (1), alwaysinsert:=True
Tabela.ListRows(linhaTabela + 1).Range.Copy
Tabela.ListRows(1).Range.PasteSpecial xlPasteAllUsingSourceTheme, Operation:=xlNone _
    , SkipBlanks:=False, Transpose:=False
maximo = WorksheetFunction.Max(Range("B12:B9999"))
Tabela.ListColumns("Registro").DataBodyRange.Cells(1, 1).Value = maximo + 1
Tabela.ListColumns("Competência").DataBodyRange.Cells(1, 1).Value = "Parcela " & x & " de " & Cells(Linha + 1, 11).Value

If Tabela.ListColumns("Item").DataBodyRange.Cells(1, 1).Value = "Paciente" Then
    Tabela.ListColumns("Status Recibo / NF").DataBodyRange.Cells(1, 1).Value = ""
Else

End If

linhaTabela = linhaTabela + 1

Next x

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .CutCopyMode = False
End With

End Sub

[SandroLima]

Bom dia, AfonsoMira.

Desculpe pela demora em retornar... precisei me ausentar por um período e depois estive testando o código.

Fiz umas junções e adequações do primeiro com o segundo código que enviou e atendeu o que necessitava.

Muito obrigado pela grande ajuda.

Onde coloco o tópico por resolvido agora?

Tenha uma excelente semana.