VBA to pull data from Multiple Worksheets into One

H

Haree

Board Regular
Joined
Sep 22, 2019
Messages
146
Office Version
  1. 2016
Hello,
I am very new to Excel VBA, i have worked on a few codes based on the forums available on MR Excel. I currently require a vba code for Debtors Management. I have 12 worksheets in a workbook each one for a separate month, in which i have a column called category in which i enter Debtors to identify them and later when i receive them i categorize them under the name Debtors Received.
Now i want a separate sheet called debtors to pull all the rows categorized as debtors and debtors received from all the 12 sheets and show me the current Balance.Since i am very new i am quite blank. Any ideas would be appreciated.
Thank You
Regards
Haree
 
Sort by date Sort by votes

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.
Try:
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")
    For Each ws In Sheets
        If ws.Name <> "Debtors" Then
            LastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            For Each CustName In ws.Range("J2: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("K2:K" & LastRow)
        For Each ws In Sheets
            If ws.Name <> "Debtors" Then
                With ws
                    If WorksheetFunction.CountIf(.Range("J:J"), CustName) > 0 Then
                        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        Set fnd = .Range("B:B").SpecialCells(xlCellTypeVisible).Find("Debtors Received")
                        If Not fnd Is Nothing Then
                            .Range("A1:J" & LastRow).AutoFilter Field:=10, Criteria1:=CustName
                            .Range("A1:J" & LastRow).AutoFilter Field:=2, Criteria1:="Debtors Received"
                            With desWS
                                ws.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0)
                                ws.Range("J2:J" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0)
                                ws.Range("C2:D" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "G").End(xlUp).Offset(1, 0)
                            End With
                            .Range("A1").AutoFilter
                        End If
                        .Range("A1:J" & LastRow).AutoFilter Field:=10, Criteria1:=CustName
                        Set fnd = .Range("F:F").SpecialCells(xlCellTypeVisible).Find("Debtors")
                        If Not fnd Is Nothing Then
                            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                            .Range("A1:J" & LastRow).AutoFilter Field:=10, Criteria1:=CustName
                            .Range("A1:J" & LastRow).AutoFilter Field:=6, Criteria1:="Debtors"
                            With desWS
                                ws.Range("E2:E" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
                                ws.Range("J2:J" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0)
                                ws.Range("G2:H" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "C").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
        For Each CustName In .Range("K2:K" & LastRow)
            If CustName <> "" Then
                .Range("A1:H" & LastRow).AutoFilter Field:=2, Criteria1:=CustName
                d = WorksheetFunction.Sum(.Range("D2:D" & LastRow).SpecialCells(xlCellTypeVisible))
                h = WorksheetFunction.Sum(.Range("H2:H" & LastRow).SpecialCells(xlCellTypeVisible))
                .Range("A1").AutoFilter
                .Cells(.Rows.Count, "L").End(xlUp).Offset(1, 0) = d - h
            End If
        Next CustName
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Sorry i wasn't available for a week.
I tried the code it works perfectly for the existing data, but when i add data or sheets and run it isn't working. It shows a error

RUN TIME ERROR - 1004
Application-defined or object-defined error
 
Last edited:
Upvote 0
This macro is based on the latest file that you posted.
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
        .Range("A3:H" & LastRow).ClearContents
        .Range("K4:L" & LastRow).ClearContents
    End With
    For Each ws In Sheets
        If ws.Name <> "Debtors" Then
            LastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            For Each CustName In ws.Range("J2: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("K4:K" & LastRow)
        For Each ws In Sheets
            If ws.Name <> "Debtors" Then
                With ws
                    If WorksheetFunction.CountIf(.Range("D:D"), CustName) > 0 Then
                        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        .Range("A1:J" & LastRow).AutoFilter Field:=4, Criteria1:=CustName
                        Set fnd = .Range("C:C").SpecialCells(xlCellTypeVisible).Find("Debtors Received")
                        If Not fnd Is Nothing Then
                            .Range("A1:J" & LastRow).AutoFilter Field:=3, Criteria1:="Debtors Received"
                            With desWS
                                ws.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0)
                                .Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0) = CustName
                                ws.Range("E2:E" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "G").End(xlUp).Offset(1, 0)
                                ws.Range("G2: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("A1:J" & LastRow).AutoFilter Field:=10, Criteria1:=CustName
                        Set fnd = .Range("I:I").SpecialCells(xlCellTypeVisible).Find("Debtors")
                            If Not fnd Is Nothing Then
                                .Range("A1:J" & LastRow).AutoFilter Field:=9, Criteria1:="Debtors"
                                With desWS
                                    ws.Range("H2:H" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
                                    .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0) = CustName
                                    ws.Range("K2:K" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0)
                                    ws.Range("L2: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(D3:D" & LastRow & ")"
        .Range("H" & LastRow + 1).Formula = "=sum(H3:H" & LastRow & ")"
        .Range("L" & LastRow + 1).Formula = "=sum(L4:L" & LastRow & ")"
        .Range("L4:L" & LastRow).Formula = "=SUMIF(B2:D" & LastRow & ",K4,D2:D" & LastRow & ")-SUMIF(F2:H" & LastRow & ",K4,H2:H" & LastRow & ")"
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Try:
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("A3:H" & LastRow).ClearContents
        .Range("K3:L" & LastRow).ClearContents
    End With
    For Each ws In Sheets
        If ws.Name <> "Debtors" Then
            LastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            For Each CustName In ws.Range("J2: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("K3:K" & LastRow)
        For Each ws In Sheets
            If ws.Name <> "Debtors" And ws.Name <> "Debtors(2)" And ws.Name <> "Debtors sample" Then
                With ws
                    If WorksheetFunction.CountIf(.Range("D:D"), CustName) > 0 Then
                        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        .Range("A1:J" & LastRow).AutoFilter Field:=4, Criteria1:=CustName
                        Set fnd = .Range("C:C").SpecialCells(xlCellTypeVisible).Find("Debtors Received")
                        If Not fnd Is Nothing Then
                            .Range("A1:J" & LastRow).AutoFilter Field:=3, Criteria1:="Debtors Received"
                            With desWS
                                ws.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0)
                                ws.Range("D2:D" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0)
                                ws.Range("E2:E" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "G").End(xlUp).Offset(1, 0)
                                ws.Range("G2: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("A1:J" & LastRow).AutoFilter Field:=10, Criteria1:=CustName
                        Set fnd = .Range("I:I").SpecialCells(xlCellTypeVisible).Find("Debtors")
                            If Not fnd Is Nothing Then
                                .Range("A1:J" & LastRow).AutoFilter Field:=9, Criteria1:="Debtors"
                                With desWS
                                    ws.Range("H2:H" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
                                    ws.Range("J2:J" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0)
                                    ws.Range("K2:K" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0)
                                    ws.Range("L2: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(D3:D" & LastRow & ")"
        .Range("H" & LastRow + 1).Formula = "=sum(H3:H" & LastRow & ")"
        .Range("L4:L" & LastRow).Formula = "=SUMIF(B2:D" & LastRow & ",K4,D2:D" & LastRow & ")-SUMIF(F2:H" & LastRow & ",K4,H2:H" & LastRow & ")"
        .Range("L" & LastRow + 1).Formula = "=sum(L4:L" & LastRow & ")"
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
The party balance list which is on the debtors sheet still isn't working, but the other part is working perfectly fine, thank you so much.
Sorry didn't know that i shouldn't post the same question twice. sorry for the inconvenience caused. it would be very helpful if you could just help me get that party balance list alright.
 

Attachments

  • Capture 1.PNG
    Capture 1.PNG
    22.8 KB · Views: 9
Upvote 0
Replace this line of code:
VBA Code: 
.Range("L4:L" & LastRow).Formula = "=SUMIF(B2:D" & LastRow & ",K4,D2:D" & LastRow & ")-SUMIF(F2:H" & LastRow & ",K4,H2:H" & LastRow & ")"
with this line:
Code: 
.Range("L3:L" & LastRow).Formula = "=SUMIF(B2:D" & LastRow & ",K4,D2:D" & LastRow & ")-SUMIF(F2:H" & LastRow & ",K4,H2:H" & LastRow & ")"
 
Upvote 0
Thanks a lot . Worked perfectly fine i was able to combine around thousands of data, initially didn't come properly, i had by mistake left few fields blank later on once they were filled everything was fine . only thing is , that party balance list in the right hand side isn't working , That's not a major issue. THANK YOU SO MUCH :)
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
VBA to loop through sheets and copy to new workbook including the pivot tab
Replies
0
Views
382
simont1975
S
B
  • Solved
Averaging the difference between two dates and separating them into categories
Replies
5
Views
303
awoohaw
awoohaw
Woozypictures
  • Solved
VBA Code to copy specific rows from one sheet to another, based on cell value
Replies
6
Views
3K
Woozypictures
Woozypictures
R
  • Solved
Macro pulls multiple workbooks into one workbook - but need to pull in over 300 workbooks
Replies
5
Views
270
igold
igold
A
  • Solved
Copy Entire Workbook, save as sheet name with current date, hide all sheets except one, & attach to email
Replies
2
Views
470
Amo840812
A

Forum statistics

Threads
1,223,227
Messages
6,170,848
Members
452,361
Latest member
d3ad3y3

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