Summarizing from multiple worksheets

Hi,

I have four master sheets and one transaction sheet. From these, I have to generate a Summary report. I have written a macro to compile these. But this is taking quite a long time as after setting filter, it has to go thru all the rows in excel sheet for each of the conditions,

I am nos sure whether this is the right approach or can be bettered

I have attached the sample sheet & please help me in optimizing...

In actual, I have more than 300 running projects for more than 10 regions, each having more than 2000 transaction items.

PS: This is my first macro program & post

Sub SummarizeReport()

Dim xSOW, xDoc, MyValue, Default, xYYYYMM As String
Dim zRow, RowCtr, CostRCtr, LastSOW, LastCOST As Integer
Dim xWON As Long
Dim xSOWfnd
Dim CostFltr As Filter
   
Dim Ws1, Ws2, Ws3, Ws4, Ws5, Ws6, Ws7, Ws8 As Worksheet

Set Ws1 = Worksheets("Report")
Set Ws2 = Worksheets("Master1") 'Region
Set Ws3 = Worksheets("Master2") 'Project
Set Ws4 = Worksheets("Master3") 'Expense Group
Set Ws5 = Worksheets("Master4") 'Expenses
Set Ws6 = Worksheets("Transaction")

Ws1.Activate
' Print Headings
    Ws1.Range("A1").Value = "Region"
    Ws1.Range("b1").Value = "Project"
    Ws1.Range("c1").Value = "Expense"
    Ws1.Range("d1").Value = "Amount"
    
    Ws2.Activate        'Region Master1
    LastRegion = Ws2.Range("A" & Rows.Count).End(xlUp).Row

    Ws4.Activate        'Exp Group
    LastExp = Ws4.Range("A" & Rows.Count).End(xlUp).Row
    
    Ws5.Activate        'Exp Items Group
    LastExpIt = Ws5.Range("A" & Rows.Count).End(xlUp).Row
    
    Ws1.Activate   'Main Sheet : Find last row
    lastRow = Ws1.Range("A" & Rows.Count).End(xlUp).Row

RowCtr = lastRow + 1
For RegCounter = 2 To LastRegion
    Set curcell = Ws2.Cells(RegCounter, 1)
        With Ws3.Range("a1:a200")
            Set xRegfnd = .Find(curcell.Value, LookIn:=xlValues)
            If Not xRegfnd Is Nothing Then
                firstReg = xRegfnd.Address
                PrevPrj = ""
                Do
                    CurReg = xRegfnd.Address
                    PrjNumber = Replace(CurReg, "A", "B")
                    xReg = curcell.Value
                    xPrj = Ws3.Range(PrjNumber).Value
                    CurPrj = xPrj
                    Ws1.Cells(RowCtr, 1).Value = xReg
                    Ws1.Cells(RowCtr, 2).Value = xPrj
                    ' Populate Exp Groups
                    If CurPrj <> PrevPrj Then
                        PrevPrj = CurPrj
                        For ExpCtr = 2 To LastExp
'                           PopulateCosts MyValue, xSOW, xWON
                            'Ws1.Cells(RowCtr, 1).Value = MyValue
                            Ws1.Cells(RowCtr, 1).Value = xReg
                            Ws1.Cells(RowCtr, 2).Value = xPrj
                            Ws1.Cells(RowCtr, 3).Value = Ws4.Cells(ExpCtr, 1)
                            RowCtr = RowCtr + 1
                        Next ExpCtr
                    End If
                    Set xRegfnd = .FindNext(xRegfnd)
                Loop While Not xRegfnd Is Nothing And xRegfnd.Address <> firstReg
            End If
        End With
Next RegCounter

CurRowCtr = RowCtr   'Store total rows written
RowCtr = lastRow + 1 'Set to first row
'Start populating amounts
Ws1.Activate
For Ctr = RowCtr To CurRowCtr
    
    xReg = Ws1.Cells(Ctr, 1).Value
    xPrj = Ws1.Cells(Ctr, 2).Value
    xExp = Ws1.Cells(Ctr, 3).Value
    
    Set curcell = Ws1.Cells(Ctr, 3)
    
    'Add routine here to read all the current run items,
    'Take expense group & project,
    'Read Expense Items from Master4 sheet.
    'Read transactions for expense item & project, Add to Reports amount column
    
        With Ws5.Range("B1:B" & LastExpIt)
        
            Set xExpfnd = .Find(curcell.Value, LookIn:=xlValues)
            If Not xExpfnd Is Nothing Then
                xFExpAddr = xExpfnd.Address
                PrvExpAdd = ""
                Do
                    xExpAddr = xExpfnd.Address
                    xItmAddr = Replace(xExpAddr, "B", "A")
                    xItemNm = Ws5.Range(xItmAddr).Value
                    'MsgBox "Current Exp Head " & xItemNm
                    'Read Transactions
                    Ws6.Activate
                    Ws6.AutoFilterMode = False
                    Ws6.Range("A1").AutoFilter Field:=1, Criteria1:=xPrj
                    Ws6.Range("A1").AutoFilter Field:=3, Criteria1:=xItemNm

                    'Count total rows retriewed
                    lr1 = Ws6.Range("A" & Rows.Count).End(xlUp).Row
                    xTrRows = Ws6.Range("A1:A" & lr1).SpecialCells(xlCellTypeVisible).Count - 1
                    ReDim rngArray(1)
                    'MsgBox "Total number of filtered rows are " & xTrRows
                    'If xTrRows > 1 Then
                        For j = 2 To lr1
                            If Not Cells(j, "A").EntireRow.Hidden Then
                                xExpAmt = Cells(j, "D").Value
                                Ws1.Cells(Ctr, 4).Value = Ws1.Cells(Ctr, 4).Value + xExpAmt
                            End If
                        Next j
                    'End If
                    '
                    Ws5.Activate
                    Set xExpfnd = .FindNext(xExpfnd)
                Loop While Not xExpfnd Is Nothing And xExpfnd.Address <> xFExpAddr
            End If
        End With
Next Ctr

End Sub

Thanks,
VB