Create report balances for many customers

Sub CreateReport()
Dim mName As String
Dim mFB, mDeb, mCred As Currency
Dim Header1 As Variant, Header2 As Variant
Dim lRow, lRow2, x, y As Long
Dim mFind As Range
Dim sFB As Boolean

Application.EnableEvents = False
Application.ScreenUpdating = False

Range("A1:G" & Range("A" & Rows.Count).End(xlUp).Row).Delete shift:=xlUp

Header1 = Array("Name", "First Balance", "Debit", "Credit", "Balance")
Header2 = Array("Item", "Date", "Debit", "Credit", "Balance", "Case", "Describe")

Sheets("Sheet2").Select

For Each cell In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
    If cell.Offset(0, 2).Value = "x" Then
        mName = cell.Value
        mFB = cell.Offset(0, 1).Value
        
        With Sheets("Sheet3")
            lRow = .Range("A" & Rows.Count).End(xlUp).Row + 5
            lRow2 = lRow + 3
            .Select
            
            With .Range(Cells(lRow, "A"), Cells(lRow, "E"))
                .Value = Header1
                .Font.Bold = True
                .Interior.ColorIndex = 15
            End With
            
            With .Range(Cells(lRow, "A"), Cells(lRow + 1, "E"))
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeTop).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                .Borders(xlInsideVertical).LineStyle = xlContinuous
            End With
            
            With .Range(Cells(lRow2, "A"), Cells(lRow2, "G"))
                .Value = Header2
                .Font.Bold = True
                .Interior.ColorIndex = 15
            End With
            
            Set mFind = Sheets("Sheet1").Range("D4:D" & Sheets("Sheet1").Range("D" & Rows.Count).End(xlUp).Row).Find(mName)
            firstAddress = mFind.Address
            x = x + 1
            
            If mFB <> 0 Then
                lRow2 = lRow2 + 1
                .Range("A" & lRow2).Value = x
                .Range("E" & lRow2).Value = mFB
                .Range("G" & lRow2).Value = "First Balance"
            End If
            
            Do
                lRow2 = lRow2 + 1
                x = x + 1
                .Range("A" & lRow2).Value = x
                .Range("B" & lRow2).Value = mFind.Offset(0, -3).Value
                .Range("C" & lRow2).Value = mFind.Offset(0, -2).Value
                .Range("D" & lRow2).Value = mFind.Offset(0, -1).Value
                .Range("F" & lRow2).Value = mFind.Offset(0, 1).Value
                .Range("G" & lRow2).Value = mFind.Offset(0, 2).Value
                Set mFind = Sheets("Sheet1").Range("D4:D" & Sheets("Sheet1").Range("D" & Rows.Count).End(xlUp).Row).FindNext(mFind)
            Loop While mFind.Address <> firstAddress

            If mFB = 0 Then
                x = x - 1
                sFB = True
            End If
            
            lRow2 = lRow2 - x
            y = x
            
            Do
                y = y - 1
                lRow2 = lRow2 + 1
                If .Range("E" & lRow2).Value = 0 And sFB = True Then
                    .Range("E" & lRow2).Value = .Range("C" & lRow2).Value - .Range("D" & lRow2).Value
                    sFB = False
                ElseIf .Range("E" & lRow2).Value = 0 Then
                    .Range("E" & lRow2).Value = .Range("E" & lRow2 - 1).Value + .Range("C" & lRow2).Value - .Range("D" & lRow2).Value
                End If
            Loop Until y = 0
            
            With .Range(.Cells(lRow2 - x, "A"), .Cells(lRow2, "G"))
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeTop).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                .Borders(xlInsideVertical).LineStyle = xlContinuous
            End With
            
            mDeb = Application.WorksheetFunction.Sum(.Range(.Cells(lRow2 + 1 - x, "C"), .Cells(lRow2, "C")))
            mCred = Application.WorksheetFunction.Sum(.Range(.Cells(lRow2 + 1 - x, "D"), .Cells(lRow2, "D")))
            .Range("A" & lRow + 1).Value = mName
            .Range("B" & lRow + 1).Value = mFB
            .Range("C" & lRow + 1).Value = mDeb
            .Range("C" & lRow + 1).NumberFormat = "[$€-2] #,##0.00"
            .Range("D" & lRow + 1).Value = mCred
            .Range("E" & lRow + 1).Value = .Range("E" & lRow2).Value
            x = 0
        End With
    End If
Next cell

With Columns("A:G")
    .EntireColumn.AutoFit
    .HorizontalAlignment = xlCenter
End With

Range("A1:G5").Delete shift:=xlUp

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Sub xAddAll()
For Each cell In Range("D2:D" & Range("B" & Rows.Count).End(xlUp).Row)
    cell.Value = "x"
Next cell
End Sub

Sub xRemoveAll()
Range("D2:D" & Range("B" & Rows.Count).End(xlUp).Row).ClearContents
End Sub

Private Sub CommandButton1_Click()
Call xAddAll
End Sub

Private Sub CommandButton2_Click()
Call xRemoveAll
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Columns("D")) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = "x" Then
    Target.Value = vbNullString
Else
    Target.Value = "x"
End If
End Sub

Private Sub Worksheet_Activate()
Dim qUpdate As Integer
qUpdate = MsgBox("Would you like to update the report?", vbYesNo)
If qUpdate = vbYes Then Call CreateReport
End Sub

Dim qRemoveB0 As Integer

qRemoveB0 = MsgBox("Would you like to remove the customers with zero balance?", vbYesNo)
If qRemoveB0 = vbYes Then
    For x = lRow2 To 1 Step -1
        If Range("E" & x).Value = "Balance" And Range("E" & x + 1).Value = 0 Then
            lRow = Range("A" & x + 3).End(xlDown).Row + 4
            Range(Cells(x, "A"), Cells(lRow, "G")).Delete
        End If
    Next x
End If