Consolidation of Multiple Sheet into one

[Shabbo]

Dear Sir,

I have attached excel file which has got 39 sheets into same format and I want to consolidate into one sheet.

please advice.

 

[chirayu]

Sub consolidator()

Dim ws As Worksheet
Dim Curr, Consol, FstRow, LstRow As String
Dim finder

ActiveWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)

ActiveSheet.Name = "Consolidated"

Consol = ActiveSheet.Name

Range("A1").Value = "Date"
Range("B1").Value = "No."
Range("C1").Value = "Particulars"
Range("D1").Value = "Debit"
Range("E1").Value = "Credit"
Range("F1").Value = "Balance"

For Each ws In ActiveWorkbook.Worksheets

    If ws.Name Like "Page*" Then
   
        ws.Select
        Curr = ws.Name
       
        On Error Resume Next
        finder = Cells.Find(What:="Total", LookIn:=xlFormulas, LookAt:=xlWhole)
       
        If IsEmpty(finder) Then
            LstRow = Range("A" & Cells(Rows.Count, "A").End(xlUp).Row).Row
        Else
            LstRow = finder - 1
        End If
       
        Cells.Find(What:="Particulars", LookIn:=xlFormulas, LookAt:=xlWhole).Activate
        FstRow = ActiveCell.Row + 1
       
        Range("A" & FstRow & ":G" & LstRow).Copy
        Worksheets(Consol).Select
        Range("A" & Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Worksheets(Curr).Select
       
    Else
    End If
   
Next

Worksheets(Consol).Select
Range("A1").Select

MsgBox "Macro completed", vbInformation, ""

End Sub

 

[Shabbo]

Sub consolidator()

Dim ws As Worksheet
Dim Curr, Consol, FstRow, LstRow As String
Dim finder

ActiveWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)

ActiveSheet.Name = "Consolidated"

Consol = ActiveSheet.Name

Range("A1").Value = "Date"
Range("B1").Value = "No."
Range("C1").Value = "Particulars"
Range("D1").Value = "Debit"
Range("E1").Value = "Credit"
Range("F1").Value = "Balance"

For Each ws In ActiveWorkbook.Worksheets

    If ws.Name Like "Page*" Then
  
        ws.Select
        Curr = ws.Name
      
        On Error Resume Next
        finder = Cells.Find(What:="Total", LookIn:=xlFormulas, LookAt:=xlWhole)
      
        If IsEmpty(finder) Then
            LstRow = Range("A" & Cells(Rows.Count, "A").End(xlUp).Row).Row
        Else
            LstRow = finder - 1
        End If
      
        Cells.Find(What:="Particulars", LookIn:=xlFormulas, LookAt:=xlWhole).Activate
        FstRow = ActiveCell.Row + 1
      
        Range("A" & FstRow & ":G" & LstRow).Copy
        Worksheets(Consol).Select
        Range("A" & Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Worksheets(Curr).Select
      
    Else
    End If
  
Next

Worksheets(Consol).Select
Range("A1").Select

MsgBox "Macro completed", vbInformation, ""

End Sub

Dear SIr,

I got an error after pasting this code.

Please refer attached sheet.

 

[chirayu]

Macro will error if "Consolidated" sheet is already in file. So you will need to delete that sheet before you run the macro. I've rechecked my code & you need to replace this bit

        On Error Resume Next
        finder = Cells.Find(What:="Total", LookIn:=xlFormulas, LookAt:=xlWhole)

with this bit

        On Error Resume Next
        finder = Cells.Find(What:="Total", LookIn:=xlFormulas, LookAt:=xlWhole).Row

for some reason the ".Row" part at the end was missing