Question

我编写了以下代码，但未能按照我希望的方式循环。

我的数据集每600个单元格更改为新的一天，我想循环它以便进行正确的计算。在600个单元块之间，有15个数据子集的长度都不同。然而DO遵循相同的模式，即有一个空白，然后是2个无用的标题单元格，不需要计算。

如何循环此代码以便它将运行15个子集然后重复每600个单元格？谢谢。

 Sub SelectandCount()
    Dim Top As Double
    Dim Bottom As Double
    Dim Ratio As Double
    Dim count As Integer

    For count = 0 To 600

    N = Cells(1, 1).End(xlDown).Row
    Range("C4:C" & N).Select

    Rownum = Selection.Rows.count

    NumberofRows = Rownum * 0.2
    AdjustedNumberofRows = Round(NumberofRows)

    Sheet1.Range("E1").Value = Array(" As Number")
    Worksheets(1).Range("E2").Value = AdjustedNumberofRows

    ActiveCell.Resize(AdjustedNumberofRows, 1).Select

    Topsum = Application.WorksheetFunction.sum(Selection)
    Top = (Topsum / AdjustedNumberofRows)
    Sheet1.Range("F1").Value = Array("Top")
    Worksheets(1).Range("F2").Value = Top

    Range("C3").End(xlDown).Select
    ActiveCell.Offset(1 - AdjustedNumberofRows).Resize(AdjustedNumberofRows).Select

    Bottomsum = Application.WorksheetFunction.sum(Selection)
    Bottom = (Bottomsum / AdjustedNumberofRows)

    Sheet1.Range("G1").Value = Array("Bottom")
    Worksheets(1).Range("G2").Value = Bottom

    MetricRatio = (Top / Bottom)
    Sheet1.Range("H1").Value = Array("Ratio")
    Worksheets(1).Range("H2").Value = Ratio
    Next
   'ActiveCell.Offset(4, 0).Resize(AdjustedNumberofRows).Select

    MsgBox ("Done")

    End Sub

Answer 1

假设：

数据集位于C列
数据集彼此跟随，每个数据集正好是600行宽
datasubsets是数据集的一部分
datasubset以空单元格开头，之后没有任何空单元格（即：下一个空单元格将是下一个子集开头的单元格）
datasubset相关数据从第4行开始（第一行为空，第二行为第二行）

然后你可以试试这个

Option Explicit

Sub SelectandCount()

Dim AdjustedNumberofRows As Long, iDataSet As Long, iData As Long
Dim sht As Worksheet
Dim dataSetIniCell As Range, dataSubSetIniCell As Range, dataSubSetRng As Range

Set sht = ThisWorkbook.Worksheets("Sheet1")

iData = -1
Set dataSetIniCell = sht.Cells(1, 3)
Do While Not IsEmpty(dataSetIniCell.Offset(1))

    Call WriteHeaders(iDataSet, iData, sht.Range("E1:H1"))

    Set dataSubSetIniCell = dataSetIniCell
    Do While Not IsEmpty(dataSubSetIniCell.Offset(1)) And dataSubSetIniCell.Row - dataSetIniCell.Row < 600

        iData = iData + 1
        Set dataSubSetRng = sht.Range(dataSubSetIniCell.Offset(3), dataSubSetIniCell.Offset(3).End(xlDown))

        AdjustedNumberofRows = Round(dataSubSetRng.Rows.count * 0.2)

        sht.Range("E1:G1").Offset(iData) = Array(AdjustedNumberofRows, _
                                                 Application.WorksheetFunction.Sum(dataSubSetRng.Resize(AdjustedNumberofRows)) / AdjustedNumberofRows, _
                                                 Application.WorksheetFunction.Sum(dataSubSetRng.Offset(dataSubSetRng.Rows.count - AdjustedNumberofRows).Resize(AdjustedNumberofRows)) / AdjustedNumberofRows)

        sht.Range("H1").Offset(iData) = sht.Range("F1").Offset(iData) / sht.Range("G1").Offset(iData)

        Set dataSubSetIniCell = dataSubSetIniCell.Offset(1).End(xlDown).Offset(1)
    Loop

    Set dataSetIniCell = dataSetIniCell.Offset(600)

Loop

MsgBox ("Done")

End Sub


Sub WriteHeaders(iDataSet As Long, iData As Long, refRng As Range)

iDataSet = iDataSet + 1
refRng.Resize(, 1).Offset(iData + 1).Value = "DataSet " & iDataSet
refRng.Offset(iData + 2).Value = Array(" As Number", "Top", "Bottom", "Ratio")
iData = iData + 2

End Sub

在VBA中挑战循环问题

1 个答案: