用VBA实现日期段按单个条件查找某一列数据返回到其他工作表指定单元格区域内

shiruiqiang

等审核吧

雷雷爸

shiruiqiang 发表于 2023-6-2 15:01
等审核吧

感谢老师，我刚刚测试了一下，基本满足了，不过就是超过240个数据我想改成248个，没有提示而是报错了，还有就是两张工作表都不能加密保护工作表了

shiruiqiang

1、If n > 248 Then
MsgBox "提取到符合的数值共:" & n & "个;超出限定数量248个！”
2、打开工作表时先解锁，好像是uprotect（“密码”），最后protect。自己搜索一下

雷雷爸

不加密也没事老师，我也操作不好，用的时候注意一点就可以了，我刚刚数了一下填充的表格是32行，我刚刚试了一下出现了这些情况，没有提示超出248个，我附个图老师

shiruiqiang

没注意，是这样的

wzr105

代码供参考：
Sub FillData()
    Dim wsInput As Worksheet
    Dim wsOutput As Worksheet
    Dim rngInput As Range
    Dim rngOutput As Range
    Dim startDate As Date
    Dim endDate As Date
    Dim strengthLevel As String
    Dim rowCounter As Long
    Dim colCounter As Long
    Dim maxEntries As Long
   
    ' Set worksheets
    Set wsInput = ThisWorkbook.Sheets("试块强度输入")
    Set wsOutput = ThisWorkbook.Sheets("抗压强度评定")
   
    ' Set input range
    Set rngInput = wsInput.Range("B2:K" & wsInput.Cells(wsInput.Rows.Count, "B").End(xlUp).Row)
   
    ' Set output range
    Set rngOutput = wsOutput.Range("E5:L35")
   
    ' Get start date, end date, and strength level
    startDate = wsOutput.Range("O3").Value
    endDate = wsOutput.Range("O4").Value
    strengthLevel = wsOutput.Range("P4").Value
   
    ' Initialize counters
    rowCounter = 1
    colCounter = 1
    maxEntries = 248
   
    ' Clear output range
    rngOutput.ClearContents
   
    ' Fill output range
    For Each cell In rngInput.Rows
        If cell.Columns("B").Value >= startDate And cell.Columns("B").Value <= endDate And cell.Columns("K").Value = strengthLevel Then
            rngOutput.Cells(rowCounter, colCounter).Value = cell.Columns("I").Value
            colCounter = colCounter + 1
            If colCounter > 8 Then ' change rows when reaching the end of a row
                colCounter = 1
                rowCounter = rowCounter + 1
            End If
            If rowCounter > 31 Then ' stop when reaching the max number of entries
                MsgBox "已达到最大条目数 (" & maxEntries & "). 无法添加更多数据."
                Exit Sub
            End If
        End If
    Next cell
End Sub

wzr105

Sub FillData()
    Dim wsInput As Worksheet
    Dim wsOutput As Worksheet
    Dim rngInput As Range
    Dim rngOutput As Range
    Dim startDate As Date
    Dim endDate As Date
    Dim strengthLevel As String
    Dim rowCounter As Long
    Dim colCounter As Long
    Dim maxEntries As Long
   
    ' Set worksheets
    Set wsInput = ThisWorkbook.Sheets("试块强度输入")
    Set wsOutput = ThisWorkbook.Sheets("抗压强度评定")
   
    ' Set input range
    Set rngInput = wsInput.Range("B2:K" & wsInput.Cells(wsInput.Rows.Count, "B").End(xlUp).Row)
   
    ' Set output range
    Set rngOutput = wsOutput.Range("E5:L35")
   
    ' Get start date, end date, and strength level
    startDate = wsOutput.Range("O3").Value
    endDate = wsOutput.Range("O4").Value
    strengthLevel = wsOutput.Range("P4").Value
   
    ' Initialize counters
    rowCounter = 1
    colCounter = 1
    maxEntries = 248
   
    ' Clear output range
    rngOutput.ClearContents
   
    ' Fill output range
    For Each cell In rngInput.Rows
        If cell.Columns("B").Value >= startDate And cell.Columns("B").Value <= endDate And cell.Columns("K").Value = strengthLevel Then
            rngOutput.Cells(rowCounter, colCounter).Value = cell.Columns("I").Value
            colCounter = colCounter + 1
            If colCounter > 8 Then ' change rows when reaching the end of a row
                colCounter = 1
                rowCounter = rowCounter + 1
            End If
            If rowCounter > 31 Then ' stop when reaching the max number of entries
                MsgBox "已达到最大条目数 (" & maxEntries & "). 无法添加更多数据."
                Exit Sub
            End If
        End If
    Next cell
End Sub

shiruiqiang

你就把brr设置成brr（1 to 5000,1 to 8）就行，越大越好，反正超出248个就退出。
如果设定1 to 31，导致n值一大，超出数组范围。
另，自定义函数有问题，表处理不了

shiruiqiang

或者这句话放到上面，一超248个就退出。不能统计出符合的数量

全党

雷雷爸 发表于 2023-6-2 19:21
不加密也没事老师，我也操作不好，用的时候注意一点就可以了，我刚刚数了一下填充的表格是32行，我刚刚试了 ...

你的表格有大小要求吗，如果没有也可以判断一下，超过248后，自动插入行以适应数据个数。或者判断超过248提示，点击确定插入行，取消重新输入起止日期。