查找最新的阅读日期和复制深度列到新表

Question

我有一个excel工作簿，其中数据已由用户导入。见图。

我想找到最近的日期并将相应日期（最近的）的深度值复制到一个名为“隐藏”的单独表格我的问题是导入的数据集的数量取决于数据集的数量用户导入因此它是动态的。读取日期所在的单元格也是动态的，具体取决于深度的值（不总是17.5）

以下是我一直在使用的一些代码

Sub Copy_Depth1()

Dim i As Integer
Dim j As Integer

j = 1
i = 1

Do Until j = Sheets("Hidden").Range("B2").Value 'I count how many times data has been imported to this sheet in this cell in this specific case j is 3

With Sheets("Data Importation Sheet")
Set Cell2 = .Columns(i).Find(What:="Reading Date:", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlDown, MatchCase:=False, SearchFormat:=False)
Set Cell3 = Cell2.Offset(1, 0)
Debug.Print Cell3.FormulaR1C1
End With

i = i + 7
j = j + 1

Loop

End Sub

任何提示/帮助将不胜感激！提前谢谢！

Answer 1

Sub Copy_depth_Updated()
Dim dataWS As Worksheet, hiddenWS As Worksheet
Dim tempDate As String, mostRecentDate As String
Dim datesRng As Range, recentCol As Range, headerRng As Range, dateRow As Range, cel As Range

Set dataWS = Worksheets("Data Information Sheet")
Set hiddenWS = Worksheets("Hidden")

Set headerRng = dataWS.Range(dataWS.Cells(1, 1), dataWS.Cells(1, dataWS.Cells(1, Columns.Count).End(xlToLeft).Column))
'headerRng.Select

For Each cel In headerRng
    If cel.Value = "Depth" Then
        Set dateRow = cel.EntireColumn.Find(what:="Reading Date:", LookIn:=xlValues, lookat:=xlPart)
        Set datesRng = dataWS.Cells(dateRow.Row + 1, dateRow.Column)
        'datesRng.Select

        ' Find the most recent date
        tempDate = Left(datesRng, 10)
        If tempDate > mostRecentDate Then
            mostRecentDate = tempDate
            Set recentCol = datesRng
        End If
    End If
Next cel

Dim copyRng As Range
With dataWS
    Set copyRng = .Range(.Cells(2, recentCol.Column), .Cells(.Cells(2, recentCol.Column).End(xlDown).Row, recentCol.Column))
End With

hiddenWS.Range(hiddenWS.Cells(2, 1), hiddenWS.Cells(copyRng.Rows(copyRng.Rows.Count).Row, 1)).Value = copyRng.Value

End Sub

这有点冗长，但应该有用。它将查找具有“深度”的列，然后查看该列的日期。这应该允许您添加/删除组中的列，使其更加动态。

如果需要调整或其他任何内容，请告诉我。