create report balances for many customers Solved/Closed

Question

hi
here this  is  the  first  post   and  I  hope  find  what I'm looking for despite  my  request  is  not  easy 
I have  data  in  sheet1 contains  many  process  and  show  the  customers  which  paid  and  unpaid    and   the   sheet2  contains  first  of  balance    for  some  customers    what   I  wand  in  sheet3   contains   dropdown  list  in b1   when  I  select   the  customer  should show details as  in  my  picture 3  and  if  i  select  another should  copy  to  the  bottom  and  if  no  select  any  name  should  all  data for all customers 
as you see   in b3  first  this  value  should  bring  from sheet2  if  the  customer contains  that  also in row 6  at  the  same  thing  and  about  the  balance should  the  next row is 7  in column e "BALANCE"  should be   the  formula  like  this  balance=first +debit-credit
and  the  next name  doesn't  contain first balnce in sheet2   the  first in cell b15  should be  0 and     there  is  no first  value  in row18 
sheet1



sheet2



sheet3


 I  hope to somebody helps me

TrowaD · Answer

Hi Abdomegahri,

In case no one else replies, know that I've seen your query and will prvide assistance once I have the time. I'm helping out someone else at the moment.

Best regards,
Trowa

abdomegahri · Answer

Hi, Trowa  
I happy  to  hear   you  again !
actually       I  don't   want copying  the previous name to the bottom, and  create duplicates  
and    I   don't  search  by   CTRL+F     if   do  that     by   macro  it  will   a  great         I    think    you   can  overcome  if    I  select   again  the   same   customer   by   message  inform  me   this  customer  is  existed  and  ignore  copying  again  to  the  bottom .
to   understand  why I  ask  this  way    my  manager  sometime   asks  me   some  customers   not   all  so      I would   this  macro   is  flexible   when  I search   by  dropdown    whether  ALL   by  add  to  dropdown  or  by  select  name   every  time.
finally   if  you  see  any  another  way  to  do  that  I'm all ears  
thanks again

TrowaD · Answer

Hi Abdomegahri, There are a number of codes that need to be placed in either a standard module, sheet2 or sheet3. Let's start with the standard module: 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 Then the codes for sheet2: 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 And finally the code for sheet3: 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 Now you can add 2 buttons on sheet2. One is for adding an "x" in column D for all names and one to remove them all. Simply click a cell in column D to add or remove a single "x". Once the "x"'s are in place, select sheet3 and a message pops up, asking to update the report. Click Yes to update or No if you still want to see what is currently on the sheet. Hopefully it is to your liking. Best regards, Trowa

abdomegahri · Answer

Hi Trowa,
sorry  if  I  don't  explain clearly   I  would  that  in  sheet3  after  show  all  the  customers  then  delete  the  customer  contain the  balance  is  0  in COl E

TrowaD · Answer

Hi Abdomegahri,

Ok, for that I adjusted the CreateReport code.

Declare an extra variable at the top:
Dim qRemoveB0 As Integer

And add the following before the End Sub line (last line of the code):
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

Once you decide to update the report, an extra question is asked to remove the customers with a balance of zero.

Best regards,
Trowa

Create report balances for many customers

5 responses

Similar discussions

Subscribe To Our Newsletter!