Pull Data From Multiple Sheets through VBA

[Haree]

I'm trying to write a Macro/VBA that will pull certain data from different sheets, ( Basically 12 Sheets a separate sheet for each Month ) into a different sheet. I'm not sure where to start.

The Macro will need to be able to look through the rows in the 12 sheets and pull the necessary cells that meet the following criteria: I have a particular column named as category, if there is a cell with the value debtors i would like to pull that data to the final sheet named debtors. i am attaching a sample excel for your reference. debtors trial.xlsx

Is there a way to accomplish this?

Thanks in advance

 

[FatBoyClam]

You're a bit unclear on what you're expecting from your description, let me see if I've got it right;

Each month has 2 lists of data, side by side.

The target tab ("Debtors") also has 2 lists.

Any item in either list on any month that has the value "debtors" or "debtor received" is to have the date, party, particulars and amount copied to one of the two lists on the Debtors tab (Debtors on the left, Debtors Received on the right).

Lets see if this does the trick;

Public Sub CompileDebtors()

Dim wb As Workbook, shtMonth As Worksheet, shtDebtor As Worksheet
Dim head As Range, heads As Range, debtors As Range, debtor As Range
Dim tDebtor As Range, tDebtorReceived As Range

Set wb = ThisWorkbook
Set shtDebtor = wb.Worksheets("Debtors")

Set tDebtor = shtDebtor.Range("A3:H" & shtDebtor.Rows.Count)

tDebtor.ClearContents

Set tDebtor = shtDebtor.Range("A3")
Set tDebtorReceived = shtDebtor.Range("E3")

For Each shtMonth In wb.Worksheets
    
    If Not shtMonth Is shtDebtor Then
        
        Set heads = shtMonth.Range("1:1").Find("Category", , xlValues, xlWhole)
        
        If Not heads Is Nothing Then
        
            Do
            
                Set head = shtMonth.Range("1:1").FindNext(heads.Areas(heads.Areas.Count))
                If InStr(heads.Address, head.Address) = 0 Then
                    Set heads = shtMonth.Range(heads.Address & "," & head.Address)
                Else
                    Exit Do
                End If
            Loop
            
            For Each head In heads.Areas
                
                Set head = head.Resize(1 + Rows.CountLarge - head.Row, 1)
                
                Set debtors = head.Find("Debtors*", , xlValues, xlWhole)
                
                If Not debtors Is Nothing Then
                
                    Do
                        Set debtor = head.FindNext(debtors.Areas(debtors.Areas.Count))
                        
                        If InStr(debtors.Address, debtor.Address) = 0 Then
                            Set debtors = shtMonth.Range(debtors.Address & "," & debtor.Address)
                        Else
                            Exit Do
                        End If
                        
                    Loop
                    
                    For Each debtor In debtors.Areas
                    
                        Select Case debtor.Value
                            Case "Debtors"
                                tDebtor.Value = debtor.Offset(0, -1).Value
                                tDebtor.Offset(0, 1).Resize(1, 3) = debtor.Offset(0, 1).Resize(1, 3).Value
                            
                                Set tDebtor = tDebtor.Offset(1, 0)
                                
                            Case "Debtors Received"
                                tDebtorReceived.Value = debtor.Offset(0, -2).Value
                                tDebtorReceived.Offset(0, 1).Resize(1, 2) = debtor.Offset(0, 1).Resize(1, 2).Value
                                tDebtorReceived.Offset(0, 3) = debtor.Offset(0, 4).Value
                                
                                Set tDebtorReceived = tDebtorReceived.Offset(1, 0)
                        End Select
                    
                    
                    Next
                
                End If
                
            Next
    
        End If
        
    End If
        
Next

If tDebtor.Row > tDebtorReceived.Row Then
    Set tDebtorReceived = tDebtorReceived.Offset(tDebtor.Row - tDebtorReceived.Row)
Else

    Set tDebtor = tDebtor.Offset(tDebtorReceived.Row - tDebtor.Row)
End If

If tDebtor.Row > 3 Then

    Set tDebtor = tDebtor.Offset(0, 3)
    Set tDebtorReceived = tDebtorReceived.Offset(0, 3)
    
    
    tDebtor.Formula = "=SUM(" & tDebtor.Offset(3 - tDebtor.Row, 0).Address & ":" & tDebtor.Offset(-1, 0).Address & ")"
    
    tDebtorReceived.Formula = "=SUM(" & tDebtorReceived.Offset(3 - tDebtorReceived.Row, 0).Address & ":" & tDebtorReceived.Offset(-1, 0).Address & ")"

End If

End Sub

There's an assumption that the only sheets in the workbook are your Month sheets, and the Debtors sheet. Also that the format of each month sheet is consistent.

 

[mumps]

@Haree
According to Forum rules, you should not post the same question more than once. The original post can be found at: VBA to pull data from Multiple Worksheets into One
Please take the time to read the Forum rules. I believe that a solution has already been provided.

 

[Haree]

@mumps
I am sorry, hadn't noticed that.Since i did not receive a response for quite sometime i thought that post had become invalid and posted it again because i needed that quite urgent. Sorry for the trouble thank you.

 

[Haree]

@FatBoyClam
Thank You it worked well but i am not getting the party balance list, which is in the debtors sheet.
it would be very helpful if that also gets updated
Thank you so much

 

[Fluff]

Please do not post the same question multiple times. All clarifications, follow-ups, and bumps should be posted back to the original thread.
Per forum rules, posts of a duplicate nature will be locked or deleted (rule 12 here: Forum Rules).