VBA 中具有挑战性的循环问题答案

【问题标题】：Challenging Loop issue in VBAVBA 中具有挑战性的循环问题
【发布时间】：2016-03-19 19:47:40
【问题描述】：

我编写了以下代码，但无法让它按照我希望的方式循环。

每 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

【问题讨论】：

您可以使用每 15 行重置一次的计数器，或者您可以在数据中找到可以控制触发器的标识符。我经常通过更改日期来做到这一点，将当前日期存储为字符串变量，并根据数据添加检查它，我循环遍历它。如果有变化，我会存储新的日期并继续。
有 15 个长度各不相同的数据子集...如果没有某种指标，这将是一个挑战。您很可能需要在循环中使用条件 if/then 或 select/case。请发布某种模拟/示例数据以获取可重复的示例。
指标不同，但它们都是（A、B、C、D、E、F、H、I、J 或 K）。需要注意的是，每组都有所有这些，然后它会重新启动。我认为最合乎逻辑的方法是扫描这些并停在特定的行号处。有什么想法吗？

标签： vba excel

【解决方案1】：

假设：

数据集在 C 列中
数据集一个接一个，每个数据集正好有 600 行宽
数据子集是数据集的一部分
数据子集以空单元格开头，之后没有任何空单元格（即：下一个空单元格将是下一个子集开头的那个）
数据子集相关数据从其第 4 行开始（第一行为空，第 2 行和第 2 行为标题）

那你可以试试这个

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

【讨论】：