Pivot VBA issue.

[siddo]

I have a pivot table created where I'm trying to copy the data from pivot table to another sheet. below is the snipper of the pivot data

Sheet where im trying to move the data

With the below code im only able to iterate through the first row of the data for each user and only first row for each user is getting copied, I want the macro to move to next phase of pivot for example phase 2 of pivot and then copy phase 2 in another sheet.

Option Explicit

Sub CreatePivotAndMoveData()
    Dim wbTask As Workbook
    Dim wsPivot As Worksheet, wsMercury As Worksheet
    Dim rng As Range
    Dim lastRow As Long
    Dim taskFileName As String
    Dim dict As Scripting.Dictionary

    ' Open Task Report file
    taskFileName = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", Title:="Select Task Report File")
    If taskFileName = "False" Then Exit Sub
    Set wbTask = Workbooks.Open(taskFileName)
   
    ' Mercury sheet is already open
    Set wsMercury = ThisWorkbook.Sheets("Sheet2")
   
    ' Create a new Worksheet for the Pivot Table in the Task workbook
    Set wsPivot = wbTask.Sheets.Add
    wsPivot.name = "PivotSheet"
   
    Dim lastCol As Long
    Dim srcRange As Range
    Dim srcSheet As Worksheet
    Set srcSheet = wbTask.Sheets("Sheet1")

    ' Find the last row and column
    lastRow = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).row
    lastCol = srcSheet.Cells(1, srcSheet.Columns.Count).End(xlToLeft).Column

    ' Define the data range
    Set srcRange = srcSheet.Range(srcSheet.Cells(1, 1), srcSheet.Cells(lastRow, lastCol))

    ' Create PivotTable
    wsPivot.PivotTableWizard _
        SourceType:=xlDatabase, _
        SourceData:=srcRange, _
        TableDestination:=wsPivot.Range("A1"), _
        TableName:="PivotTable1"

    ' Setup pivot table fields
    With wsPivot.PivotTables("PivotTable1")
        .PivotFields("FirstName").Orientation = xlRowField
        .PivotFields("Tags").Orientation = xlRowField
        .PivotFields("Task Status").Orientation = xlColumnField
        .PivotFields("Task Status").Position = 1
        .PivotFields("Task Status").Orientation = xlDataField
        .PivotFields("Tag group").Orientation = xlPageField
        .PivotFields("Tag group").Position = 1
    End With

' Loop through the different phases
Dim phases As Variant
phases = Array("Phase I", "Phase II", "Phase III", "Phase IV", "Phase V")

    wsPivot.PivotTables("PivotTable1").PivotFields("Tag group").CurrentPage = "Phase"
    wsPivot.PivotTables("PivotTable1").PivotCache.Refresh
   
    ' Create a Dictionary to map Pivot names to Mercury names
    Set dict = CreateMappingDictionary()

    ' Call the subroutine to copy data
    CopyPhaseToMercury wsPivot, wsMercury, dict

    ' Close workbooks
    ' wbTask.Close SaveChanges:=False
   
End Sub

' Create a mapping dictionary
Function CreateMappingDictionary() As Scripting.Dictionary
    Dim dict As New Scripting.Dictionary
    ' Add your mappings here
   xxxxxxxxxx
    Set CreateMappingDictionary = dict
   
End Function


' Find row in Mercury based on Name
Function FindRowInMercury(name As String, ws As Worksheet) As Long
    Dim cell As Range
    Set cell = ws.Range("B3:B100").Find(What:=name, LookIn:=xlValues, LookAt:=xlPart)
    If Not cell Is Nothing Then
        FindRowInMercury = cell.row
    Else
        FindRowInMercury = 0
    End If
End Function
Sub CopyPhaseToMercury(ByRef wsPivot As Worksheet, ByRef wsMercury As Worksheet, ByVal dict As Scripting.Dictionary)
    Dim lastRow As Long
    Dim nameCell As Range
    Dim mercuryName As String
    Dim phaseName As String
    Dim rowMercury As Long
    Dim colComplete As String, colInProgress As String, colNotStarted As String
    Dim currentUser As String
    Dim lastUser As String

    ' Define the column mapping for each phase in Mercury
    Dim phaseColumns As Scripting.Dictionary
    Set phaseColumns = New Scripting.Dictionary
    phaseColumns.Add "Phase I", Array("P", "Q", "R")
    phaseColumns.Add "Phase II", Array("T", "U", "V")
    phaseColumns.Add "Phase III", Array("X", "Y", "Z")
    phaseColumns.Add "Phase IV", Array("AB", "AC", "AD")
    phaseColumns.Add "Phase V", Array("AF", "AG", "AH")

    lastRow = wsPivot.Cells(Rows.Count, "A").End(xlUp).row
    lastUser = ""

    For Each nameCell In wsPivot.Range("A2:A" & lastRow)
        currentUser = nameCell.Value
        phaseName = nameCell.Offset(0, 1).Value
       
        ' Skip if the row doesn't contain a user and a phase
        If currentUser = "" Or phaseName = "" Then
            GoTo ContinueLoop
        End If

        If dict.Exists(currentUser) Then
            mercuryName = dict.Item(currentUser)
        Else
            mercuryName = ""
        End If

        If mercuryName <> "" Then
            rowMercury = FindRowInMercury(mercuryName, wsMercury)
            If rowMercury > 0 Then
                If phaseColumns.Exists(phaseName) Then
                    colComplete = phaseColumns.Item(phaseName)(0)
                    colInProgress = phaseColumns.Item(phaseName)(1)
                    colNotStarted = phaseColumns.Item(phaseName)(2)
                   
                    ' Copy "Complete" value
                    wsMercury.Cells(rowMercury, colComplete).Value = nameCell.Offset(0, 2).Value

                    ' Sum and copy "In Progress" and "In Review" values
                    wsMercury.Cells(rowMercury, colInProgress).Value = nameCell.Offset(0, 3).Value + nameCell.Offset(0, 4).Value
                   
                wsMercury.Cells(rowMercury, colNotStarted).Value = nameCell.Offset(0, 5).Value  ' Open
                End If
            End If
        End If
        lastUser = currentUser
ContinueLoop:
    Next nameCell
End Sub

Request if anyone could help