存储单元格位置并递归循环

Question

我尽可能地清理了从 PDF 文件中提取的一些数据，这是我现在在 Sheet1 中所拥有的示例：

商店	日期	价值
	2024年1月1日
B店		23.47
B店		27.00
A店		33.32
.	2024年1月2日	.
A店		21.00
B店		13.76
A店		28.21
A店		00.02
B店		17.99
.	2024年1月3日	.
...		...

这就是我想要在 Sheet2 中得到的：

日期	A店	B店
2024年1月1日	33.32	23.47
		27.00
2024年1月2日	21.00	13.76
	28.21	17.99
	00.02
2024年1月3日	...	...
	...	...

这是我到目前为止的代码。它仅适用于第一个整体循环 + 查找 Sheet2 中第二个日期的位置。 Sheet2 中的值均从第 6 行开始。首先，代码在 Sheet1 的

Date

列中查找第一个非空单元格，然后将该单元格的值分配给 Sheet2 中的单元格 A6。然后，它查找相应的 StoreA 和 StoreB 值，并在 Sheet2 的列中对它们进行相应的分配。最后，它会查找 B:C 范围内最后使用的行，并找到 A 列中下一个日期值将进入的值。我想做的是再次调用日期循环，以便它查找日期，然后查找下一个相应的存储值，依此类推。

我知道问题在于，通过递归调用函数，我将变量重新设置回原始位置/值，这导致无限循环，而不是“从最后一个循环停止的位置开始”，但我'我不确定如何将第一个静态位置分配给第一个值，然后将动态单元格位置分配给以下情况。解决方案看起来很简单，但我真的不知道它是什么。我认为 Range.Find 方法可能就是我正在寻找的方法，但据我所知，它只会一次遍历整个列范围，而我需要的更多的是嵌套循环（？），作为下一个日期的位置Sheet2 中的值取决于前一天的值范围使用的行数。

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

Answer 1

• 使用

  Dict+Collection

  变换表格

微软文档：

Range.Resize 属性 (Excel)

Range.CurrentRegion 属性 (Excel)

Option Explicit
Sub Demo()
    Dim objDic As Object, rngData As Range
    Dim i As Long, sKey, iR As Long
    Dim arrData, arrRes, sDate As String
    Dim oSht1 As Worksheet, oSht2 As Worksheet
    Const START_ROW = 6 ' first data row on sheet2
    Set oSht1 = Sheets("Sheet1")
    Set oSht2 = Sheets("Sheet2")
    Set objDic = CreateObject("scripting.dictionary")
    Set rngData = oSht1.Range("A1").CurrentRegion
    arrData = rngData.Value
    For i = LBound(arrData) + 1 To UBound(arrData)
        sKey = arrData(i, 2)
        If Len(sKey) > 0 Then
            If Not objDic.exists(sKey) Then
                objDic(sKey) = Array(New Collection, New Collection)
                sDate = sKey
            End If
        Else
            If arrData(i, 1) = "StoreA" Then
                iR = 0
            ElseIf arrData(i, 1) = "StoreB" Then
                iR = 1
            End If
            objDic(sDate)(iR).Add "'" & arrData(i, 3) ' number as text
            ' objDic(sDate)(iR).Add "'" & arrData(i, 3) ' number
        End If
    Next i
    iR = objDic.Count + 1
    For Each sKey In objDic.Keys
        iR = Application.Max(objDic(sKey)(0).Count, objDic(sKey)(1).Count) + iR
    Next
    ReDim arrRes(iR, 1 To 3)
    arrRes(0, 1) = "Date"
    arrRes(0, 2) = "StoreA"
    arrRes(0, 3) = "StoreB"
    iR = 0
    For Each sKey In objDic.Keys
        iR = iR + 1
        arrRes(iR, 1) = sKey
        For i = 1 To Application.Max(objDic(sKey)(0).Count, objDic(sKey)(1).Count)
            If i <= objDic(sKey)(0).Count Then
                arrRes(iR, 2) = objDic(sKey)(0)(i)
            End If
            If i <= objDic(sKey)(1).Count Then
                arrRes(iR, 3) = objDic(sKey)(1)(i)
            End If
            iR = iR + 1
        Next
    Next
    oSht2.Cells(START_ROW, 1).Resize(UBound(arrRes), 3).Value = arrRes
End Sub