Help in existing vba which pulls data to another sheet

H

Haree

Board Regular
Joined
Sep 22, 2019
Messages
146
Office Version
  1. 2016
Hello all, I have a vba code which basically pulls my "Debtors" and "Debtors Received" from my monthly sheets .( I have 12 worksheets in a workbook, one for each month) and displays them in a separate worksheet called Debtors. The code is working fine but there is a small issue with it . I have different categories debtors and debtors received are not my only categories, for instance i have sales, Expenses , Advance received Etc. When i have advance received that particular customers debtors are not reflecting.

For instance Advance Received from John 12000
And Debtors is 15000
It doesn't even show john. This happens only with advance Received . I am attaching the sample workbook and the code. any help would be grateful. I have highlighted in yellow in my excel sheet in the sheet of April 2020 and Debtors.
Thank You

VBA Code: 
Sub GetBalance()
    Application.ScreenUpdating = False
    Dim LastRow As Long, ws As Worksheet, CustName As Range, desWS As Worksheet, d As Long, h As Long, fnd As Range
    Set desWS = Sheets("Debtors")
    With desWS
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        If LastRow < 3 Then LastRow = 3
        .Range("$A$3:H" & LastRow).ClearContents
        .Range("$K$3:L" & LastRow).ClearContents
    End With
    For Each ws In Sheets
        If ws.Name <> "Debtors" Or ws.Name <> "Total" Or ws.Name <> "Names" Then
            LastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            For Each CustName In ws.Range("$J$2:J" & LastRow)
                If CustName <> "" Then
                    If WorksheetFunction.CountIf(desWS.Range("K:K"), CustName) = 0 Then
                        With desWS
                            .Cells(.Rows.Count, "K").End(xlUp).Offset(1, 0) = CustName
                        End With
                    End If
                End If
            Next
        End If
    Next ws
    LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each CustName In desWS.Range("$K$3:K" & LastRow)
        For Each ws In Sheets
            If ws.Name <> "Debtors" Or ws.Name <> "Names" Or ws.Name <> "Total" Then
                With ws
                    If WorksheetFunction.CountIf(.Range("D:D"), CustName) > 0 Then
                        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        .Range("$A$1:J" & LastRow).AutoFilter Field:=4, Criteria1:=CustName
                        Set fnd = .Range("C:C").SpecialCells(xlCellTypeVisible).Find("Debtors Received")
                        If Not fnd Is Nothing Then
                            .Range("$A$1:J" & LastRow).AutoFilter Field:=3, Criteria1:="Debtors Received"
                            With desWS
                                ws.Range("$A$2:A" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0)
                                ws.Range("$D$2:D" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0)
                                ws.Range("$E$2:E" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "G").End(xlUp).Offset(1, 0)
                                ws.Range("$G$2:G" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "H").End(xlUp).Offset(1, 0)
                            End With
                            .Range("A1").AutoFilter
                        End If
                    End If
                    If WorksheetFunction.CountIf(.Range("J:J"), CustName) > 0 Then
                        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        .Range("$A$1:J" & LastRow).AutoFilter Field:=10, Criteria1:=CustName
                        Set fnd = .Range("I:I").SpecialCells(xlCellTypeVisible).Find("Debtors")
                            If Not fnd Is Nothing Then
                                .Range("$A$1:J" & LastRow).AutoFilter Field:=9, Criteria1:="Debtors"
                                With desWS
                                    ws.Range("$H$2:H" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
                                    ws.Range("$J$2:J" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0)
                                    ws.Range("$K$2:K" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0)
                                    ws.Range("$L$2:L" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "D").End(xlUp).Offset(1, 0)
                                End With
                                .Range("A1").AutoFilter
                            End If
                        .Range("A1").AutoFilter
                    End If
                    If ws.AutoFilterMode Then ws.AutoFilterMode = False
                End With
            End If
        Next ws
    Next CustName
    With desWS
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("D" & LastRow + 1).Formula = "=sum($D$3:D" & LastRow & ")"
        .Range("H" & LastRow + 1).Formula = "=sum($H$3:H" & LastRow & ")"
        .Range("$L$3:L" & LastRow).Formula = "=SUMIF($B$2:D" & LastRow & ",K3,$D$2:D" & LastRow & ")-SUMIF($F$2:H" & LastRow & ",K3,$H$2:H" & LastRow & ")"
        .Range("L" & LastRow + 1).Formula = "=sum($L$3:L" & LastRow & ")"
    End With
    Application.ScreenUpdating = True
End Sub


The link for the excel file is

Dropbox

www.dropbox.com www.dropbox.com
 

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).
Sort by date Sort by votes
For all the categories to appear you must comment some lines, try the following:

VBA Code: 
Sub GetBalance()
  Application.ScreenUpdating = False
  Dim LastRow As Long, ws As Worksheet, CustName As Range, desWS As Worksheet, d As Long, h As Long, fnd As Range
  Set desWS = Sheets("Debtors")
  With desWS
    LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If LastRow < 3 Then LastRow = 3
    .Range("$A$3:H" & LastRow).ClearContents
    .Range("$K$3:L" & LastRow).ClearContents
  End With
  
  For Each ws In Sheets
    If ws.Name <> "Debtors" Or ws.Name <> "Total" Or ws.Name <> "Names" Then
      LastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      For Each CustName In ws.Range("$J$2:J" & LastRow)
        If CustName <> "" Then
          If WorksheetFunction.CountIf(desWS.Range("K:K"), CustName) = 0 Then
            With desWS
              .Cells(.Rows.Count, "K").End(xlUp).Offset(1, 0) = CustName
            End With
          End If
        End If
      Next
    End If
  Next ws
  
  LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  For Each CustName In desWS.Range("$K$3:K" & LastRow)
    For Each ws In Sheets
      If ws.Name <> "Debtors" And ws.Name <> "Names" And ws.Name <> "Total" Then
        With ws
          If WorksheetFunction.CountIf(.Range("D:D"), CustName) > 0 Then
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Range("$A$1:J" & LastRow).AutoFilter Field:=4, Criteria1:=CustName
            'Set fnd = .Range("C:C").SpecialCells(xlCellTypeVisible).Find("Debtors Received")
            'If Not fnd Is Nothing Then
            '.Range("$A$1:J" & LastRow).AutoFilter Field:=3, Criteria1:="Debtors Received"
            With desWS
              ws.Range("$A$2:A" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0)
              ws.Range("$D$2:D" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0)
              ws.Range("$E$2:E" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "G").End(xlUp).Offset(1, 0)
              ws.Range("$G$2:G" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "H").End(xlUp).Offset(1, 0)
            End With
            .Range("A1").AutoFilter
            'End If
          End If
          If WorksheetFunction.CountIf(.Range("J:J"), CustName) > 0 Then
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Range("$A$1:J" & LastRow).AutoFilter Field:=10, Criteria1:=CustName
            'Set fnd = .Range("I:I").SpecialCells(xlCellTypeVisible).Find("Debtors")
            '    If Not fnd Is Nothing Then
            '        .Range("$A$1:J" & LastRow).AutoFilter Field:=9, Criteria1:="Debtors"
            With desWS
              ws.Range("$H$2:H" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
              ws.Range("$J$2:J" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0)
              ws.Range("$K$2:K" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0)
              ws.Range("$L$2:L" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "D").End(xlUp).Offset(1, 0)
            End With
            .Range("A1").AutoFilter
            '   End If
            .Range("A1").AutoFilter
          End If
          If ws.AutoFilterMode Then ws.AutoFilterMode = False
        End With
      End If
    Next ws
  Next CustName
  '
  With desWS
    LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    .Range("D" & LastRow + 1).Formula = "=sum($D$3:D" & LastRow & ")"
    .Range("H" & LastRow + 1).Formula = "=sum($H$3:H" & LastRow & ")"
    .Range("$L$3:L" & LastRow).Formula = "=SUMIF($B$2:D" & LastRow & ",K3,$D$2:D" & LastRow & ")-SUMIF($F$2:H" & LastRow & ",K3,$H$2:H" & LastRow & ")"
    .Range("L" & LastRow + 1).Formula = "=sum($L$3:L" & LastRow & ")"
  End With
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
Hi, Thanks for taking time to help me out . Sorry i did not explain i want it to filter out only the categories containing "Debtors" and "Debtors Received" . But the problem is i don't know where i went wrong when i use advance received for a Name, That particular Name's Debtors and Debtors Received aren't showing. Thanks once again
 
Upvote 0
Did you try the updated code?
Haree said:
I have highlighted in yellow in my excel sheet in the sheet of April 2020
Click to expand...
The data in yellow does not appear, but with the updated code it now does.
 
Upvote 0
Sorry Sir i was not feeling well could not respond. Yes sir i tried the updated code it does bring the values to the sheet called debtors. But it brings the values of Advance Received. I want only the values of Debtors and Debtors received. Sorry for troubling you.
 
Upvote 0
I get it. Try the new updated code.

VBA Code: 
Sub GetBalance()
  Application.ScreenUpdating = False
  Dim ws As Worksheet, desWS As Worksheet
  Dim LastRow As Long
  Dim CustName As Range
 
  Application.ScreenUpdating = False
 
  Set desWS = Sheets("Debtors")
  desWS.Range("A3:H" & Rows.Count & ",K3:L" & Rows.Count).ClearContents
 
  For Each ws In Sheets
    If ws.Name <> "Debtors" Or ws.Name <> "Total" Or ws.Name <> "Names" Then
      For Each CustName In ws.Range("J2", ws.Range("J" & Rows.Count).End(3))
        If CustName.Value <> "" And WorksheetFunction.CountIf(desWS.Range("K:K"), CustName) = 0 Then
          desWS.Cells(Rows.Count, "K").End(xlUp).Offset(1, 0) = CustName
        End If
      Next
    End If
  Next ws
 
  For Each CustName In desWS.Range("K3", desWS.Range("K" & Rows.Count).End(3))
    For Each ws In Sheets
      With ws
        If .Name <> "Debtors" And .Name <> "Names" And .Name <> "Total" Then
          If WorksheetFunction.CountIfs(.Range("D:D"), CustName, .Range("C:C"), "Debtors Received") > 0 Then
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            With .Range("$A$1:J" & LastRow)
              .AutoFilter Field:=4, Criteria1:=CustName
              .AutoFilter Field:=3, Criteria1:="Debtors Received"
            End With
            .Range("$A$2:A" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
            .Range("$D$2:D" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(Rows.Count, "F").End(xlUp).Offset(1, 0)
            .Range("$E$2:E" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0)
            .Range("$G$2:G" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(Rows.Count, "H").End(xlUp).Offset(1, 0)
            .Range("A1").AutoFilter
          End If
          If WorksheetFunction.CountIfs(.Range("J:J"), CustName, .Range("I:I"), "Debtors") > 0 Then
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            With .Range("A1:J" & LastRow)
              .AutoFilter Field:=10, Criteria1:=CustName
              .AutoFilter Field:=9, Criteria1:="Debtors"
            End With
            .Range("$H$2:H" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Range("$J$2:J" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
            .Range("$K$2:K" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0)
            .Range("$L$2:L" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(Rows.Count, "D").End(xlUp).Offset(1, 0)
            .Range("A1").AutoFilter
          End If
          If .AutoFilterMode Then .AutoFilterMode = False
        End If
      End With
    Next ws
  Next CustName
  '
  With desWS
    LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    .Range("D" & LastRow + 1).Formula = "=sum($D$3:D" & LastRow & ")"
    .Range("H" & LastRow + 1).Formula = "=sum($H$3:H" & LastRow & ")"
    .Range("$L$3:L" & LastRow).Formula = "=SUMIF($B$2:D" & LastRow & ",K3,$D$2:D" & LastRow & ")-SUMIF($F$2:H" & LastRow & ",K3,$H$2:H" & LastRow & ")"
    .Range("L" & LastRow + 1).Formula = "=sum($L$3:L" & LastRow & ")"
  End With
  Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0
Solution
Hello Sir. Thank you so much it works perfectly fine now. I will check where i have gone wrong. Thanks once again
 
Upvote 0
I made a new code with another method, sure it's faster.
I fixed some bugs and also simplified it a bit.

VBA Code: 
Sub GetBalance_2()
  Dim dic As Object
  Dim ws As Worksheet
  Dim CustName As Range
  Dim a() As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, lr As Long, n As Long
  
  Set dic = CreateObject("Scripting.Dictionary")
  dic.comparemode = vbTextCompare
  
  For Each ws In Sheets
    If ws.Name <> "Debtors" And ws.Name <> "Total" And ws.Name <> "Names" Then
      lr = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      n = n + lr
      For Each CustName In ws.Range("D2:D" & lr & ",J2:J" & lr)
        If CustName.Value <> "" Then dic(CustName.Value) = Empty
      Next
    End If
  Next ws
  ReDim b(1 To n, 1 To 8)

  For Each ws In Sheets
    If ws.Name <> "Debtors" And ws.Name <> "Total" And ws.Name <> "Names" Then
      lr = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      Erase a
      a = ws.Range("A2:N" & lr).Value
      For i = 1 To UBound(a, 1)
        If a(i, 3) = "Debtors Received" And a(i, 4) <> "" Then
          j = j + 1
          b(j, 5) = a(i, 1)
          b(j, 6) = a(i, 4)
          b(j, 7) = a(i, 5)
          b(j, 8) = a(i, 7)
        End If
        If a(i, 9) = "Debtors" And a(i, 10) <> "" Then
          k = k + 1
          b(k, 1) = a(i, 8)
          b(k, 2) = a(i, 10)
          b(k, 3) = a(i, 11)
          b(k, 4) = a(i, 12)
        End If
      Next
    End If
  Next
  
  With Sheets("Debtors")
    .Range("A3:H" & Rows.Count & ",K3:L" & Rows.Count).ClearContents
    .Range("A3").Resize(WorksheetFunction.Max(j, k), 8).Value = b
    .Range("K3").Resize(dic.Count).Value = Application.Transpose(dic.keys)
    lr = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    .Range("D" & lr + 1 & ",H" & lr + 1 & ",L" & lr + 1).Formula = "=sum(D3:D" & lr & ")"
    .Range("$L$3:L" & lr).Formula = "=SUMIF($B$2:$D$" & lr & ",K3,$D$2:$D$" & lr & ")-SUMIF($F$2:$H$" & lr & ",K3,$H$2:$H$" & lr & ")"
  End With
End Sub
 
Upvote 0
Thank you so much sir. The code is working perfectly fine and is very fast. Thanks a ton for helping me out. Should learn a lot from you.
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
VBA removing heading in spreadsheet
Replies
3
Views
273
rlv01
R
G
  • Question Question
Sort (Z-A) Macro not working
Replies
1
Views
88
NateSC
NateSC
M
  • Question Question
Copy File Names to Destination File
Replies
2
Views
326
metalscuba
M
O
  • Solved
Detecting if the cell contains strikethrough is not working
Replies
2
Views
435
Fuji
F
G
  • Solved
Typing out Excel formula in Excel Macro
Replies
1
Views
85
Macropod
Macropod

Forum statistics

Threads
1,224,823
Messages
6,181,169
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top