Guru do Excel e Power BI

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

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