Can this Chunk of Code be condensed down?

[dpiano1984]

Alright. So I'm in the process of automating a good bit on my groups daily spreadsheets. For one UserForm though, I have about 1,400 lines of code. I'm trying to streamline some things. Can this bit of code be condensed from 86 lines to maybe 50 lines? Here's the code:

Private Sub CR_Load(BucketOnly As Boolean)'This is a Subroutine that will add any transfers the user wishes to the Client Report tab. It will cycle through
'The funds and accounts numbers on the 1382 Tab and add them to the Client Report, if applicaple.




'Need the first blank cell after the fund
Sheets("Client Report").Activate
Cells.Find(TheFund, LookIn:=xlValues, Lookat:=xlWhole).Select
Dim HomeCell As Range '''Need an origin to work off of '''
Set HomeCell = ActiveCell '''Cell in Column B will be the Home Cell '''
Dim Scell2 As Range '''Scell2 will be the origin cell to make adjusments to '''


    
''''''''''''''''''''''''''''''''''''''''
'''Make Sure there is space for Scell'''
''''''''''''''''''''''''''''''''''''''''
For TR = 1 To 20
    If Controls("TR" & TR).Value = "" Then '''If Control is blank then the loop is over '''
        Exit For
    Else
        '''Loop through the rows of the Fund to find the next blank cell to input the transfer
        For i = 1 To 400
            If HomeCell.Offset(i, 5).Value = "" Then '''Cell is blank. We can add to it '''
                HomeCell.Offset(i, 5).Select
                Set Scell2 = ActiveCell
                Exit For
            Else
                If HomeCell.Offset(i, 4).Value = "Remaining Break:" Then
                    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                    '''We've reached the end of the current fund's section. We need to insert a row to add to it'''
                    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                    HomeCell.Offset(i - 1, 4).Select '''Select the next row up'''
                    Selection.EntireRow.Insert shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove '''Inserting a row'''
                    '''Reset the iterator'''
                    i = 1
                End If
            End If
        Next i
        
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        '''See if there the BucketOnly argument is true or not'''
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        If BucketOnly = True Then
            Scell2.Value = Controls("Bucket" & TR).Value '''Bucket Only: Insert only the Bucket into Scell2'''
            Scell2.Offset(0, -1).Value = Controls("Bucket" & TR).Value '''Set Column F to have the Bucket Value for lookup purposes'''
        Else '''Not Bucket Only. But Still need to see if there is a bucket in the Form'''
            If Controls("Bucket" & TR).Value <> "" Then
                Scell2.Value = Controls("Bucket" & TR).Value '''This will add the bucket value to the Client Report'''
                Scell2.Offset(0# - 1).Value = Controls("Bucket" & TR).Value '''Bucket Value to column F for lookup purposes'''
                If Scell2.Offset(1, 0).Value <> "" Then
                    Scell2.Offset(1, 0).Select
                    Selection.EntireRow.Insert shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove '''Insert new row if next row is not blank'''
                    Scell2.Offset(1, 0).Value = Controls("DivRate" & TR).Value '''Add Div Amount to the client report'''
                    Scell2.Offset(1, -1).Value = Controls("DivRate" & TR).Value '''Div Amount to Column F for lookup purposes'''
                Else
                    Scell2.Offset(1, 0).Value = Controls("DivRate" & TR).Value '''add div amount to client report'''
                    Scell2.Offset(1, -1).Value = Controls("DivRate" & TR).Value '''Div Amount to Column F for lookup purposes'''
                End If
            Else '''No Bucket'''
                Scell2.Value = Controls("DivRate" & TR).Value '''add div amount to client report'''
                Scell2.Offset(0, -1).Value = Controls("DivRate" & TR).Value '''Div Amount to Column F for lookup purposes'''
            End If
        End If
    
        '''Check to see if there is an account number for the current transaction'''
        If ShowsUp(Controls("TR" & TR)) = False Then Controls("TR" & TR).Value = Controls("TR" & TR) * (-1)
        
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        '''Perform a vlookup for the 1382 Report to get the Account Number''''''''''''''''''''''''''''''''''''
        '''If there is no account number on the report, the Account number field will read "Surpas Pending"'''
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Scell2.Offset(0, 1).Value = "=iferror(vlookup(" & Controls("TR" & TR) & ",'1382 Report'!K:P,columns(K:P),false),""Surpas Pending"")"
        
        ''''''''''''''''''''''''''''''''''''''''''''''''''''
        '''Value in TR Control will be added to the sheet'''
        ''''''''''''''''''''''''''''''''''''''''''''''''''''
        Scell2.Offset(0, -1).Value = Controls("TR" & TR).Value
        Application.CutCopyMode = False
            Range(Scell2, Scell2.Offset(0, 1)).Copy
            Range(Scell2, Scell2.Offset(0, 1)).PasteSpecial Paste:=xlPasteValues
            Range(Scell2, Scell2.Offset(0, 1)).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
    End If
Next TR '''Find the next TR and then repeat the process'''




End Sub

....Yes I like making the comments stand out....