Excel VBA递归循环实现Sheet1数据按日期拆分至Sheet2的问题

从PDF提取并初步清理后的Sheet1数据格式如下：

需要转换为Sheet2的格式，数据从第6行开始：

我编写的VBA代码仅能处理第一组数据，目前可定位Sheet2中第二个日期的放置位置，但无法循环处理后续所有日期组。代码逻辑为：先查找Sheet1日期列第一个非空单元格，将其值赋给Sheet2的A6单元格；再匹配StoreA和StoreB的数值，对应填充到Sheet2的对应列；最后根据B:C区域的最后使用行，确定下一个日期在Sheet2的A列位置。

尝试用递归调用实现日期循环，但递归会重置变量导致无限循环，无法从上一次循环结束位置继续执行。不确定如何为第一个值设置静态位置、后续设置动态单元格位置，怀疑Range.Find方法可能适用，但不知道怎么实现依赖前一日数据行数的嵌套循环。

Option Explicit

Sub setDateValues()

    Dim ws2 As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim beginnerCell As Range
    Dim nextEmptyDateCell As Range
   
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
   'set range for column B
    Set rng = ThisWorkbook.Sheets("Sheet1").Range("B2:B" & _
                     ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row)
                                                   
                                                   
   'set initial cell for beginnerCell / alternatively 
    'simply “A6”? I think this variable might only be needed 
    'for the first loop, or maybe I can re-set it to the last cell in the loop?
    Set beginnerCell = ws2.Cells(Rows.Count, "A").End(xlUp).Offset(5, 0) 
    

   'loop through column B range; find next non-empty cell and attribute cell value
   'to beginnerCell in Sheet2
    For Each cell In rng
        If Not IsEmpty(cell.Value) Then
            beginnerCell.Value = cell.Value
           cell = beginnerCell
            Exit For
        End If
    Next cell

    Dim LastRow As Long
    
    'find last used row within B:C range
    LastRow = WorksheetFunction.Max(ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row, _
                                    ws2.Cells(ws2.Rows.Count, "C").End(xlUp).Row)

   're-set beginnerCell  as two cells below that row, in column 1
    Set beginnerCell = ws2.Cells(LastRow + 2, "A")
    

      
    Dim nextCellStoreA As Range
    Dim nextCellStoreB As Range


   'set range for column A to loop through
    Set rng = ThisWorkbook.Sheets("Sheet1").Range("A2:A" & _
    ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row)
    
    'set initial cell for nextCellStoreA 
    Set nextCellStoreA = ws2.Cells(Rows.Count, "B").End(xlUp).Offset(5, 0)
    
    'set initial cell for nextCellStoreB 
    Set nextCellStoreB = ws2.Cells(Rows.Count, "C").End(xlUp).Offset(5, 0)
    
    'same issue as in the first loop; the loop starts from the beginning again, 
    'maybe I could create a variable that stores the address of the last cell?
    
    'loop through Sheet1!ColumnA range and assign values in Sheet2
    For Each cell In rng
        If cell.Value = "StoreB" Then
            nextCellStoreB.Value = cell.Offset(, 2).Value
            Set nextCellStoreB = nextCellStoreB.Offset(1, 0)

            ElseIf cell.Value = "StoreA" Then
            nextCellStoreA.Value = cell.Offset(, 2).Value
            Set nextCellStoreA = nextCellStoreA.Offset(1, 0)

        End If
                    If cell.Value = "." Then Exit For
    Next cell

End Sub

内容的提问来源于stack exchange，提问作者maliebina