VBA循环遍历一个列，获取每个位置的前10个(如果小于10，则为最大值)的范围

Question

我基本上是在尝试获取每个位置前十行的范围，如果少于十行，那么它将使用最大范围

例如，如果将下面的数据放在 A 列中，则第一个范围为 A2:A11，第二个范围为 A14:A16，第三个范围为 A17:A26

Location
London
London
London
London
London
London
London
London
London
London
London
London
Liverpool
Liverpool
Liverpool
York
York
York
York
York
York
York
York
York
York
York
York
York
York
York

我正在尝试合并它，以便我可以使用以下内容一次制作多个饼图:

Charts.Add2
ActiveChart.SetSourceData Source:=Range("'MainSheet'!$T$3:$T$14")
ActiveChart.ChartType = xlPie
ActiveChart.SetElement (msoElementLegendRight)
ActiveChart.FullSeriesCollection(1).XValues = "='MainSheet'!$I$4:$I$14"
Sheets("MainSheet").Select

例如excel文件的下载链接: https://mega.co.nz/#!PhgWTB7a!Ie0HzaA66-vsR8nDpsQzsSlLZ9A4egoDzNtuWNR8uhU

替代下载链接: https://www.dropbox.com/s/f44be4vj2b82lx1/Example_Pies.xlsx

我不知道如何做到这一点，所以我非常感谢您的帮助。

Answer 1

大规模编辑:

根据上传的文件，这是一个工作代码。优化取决于您。 久经考验和工作。

Sub CreateCharts()

    Dim Rng1 As Range, Rng2 As Range, Rng3 As Range
    Dim Val1 As Range, Val2 As Range, Val3 As Range
    Dim RngNames As Range

    Set RngNames = Sheets("MainSheet").Range("C4:C60")

    Set Rng1 = Range(GetTopRange(RngNames, "London", 10)).Offset(0, 6)
    Set Rng2 = Range(GetTopRange(RngNames, "Newcastle", 10)).Offset(0, 6)
    Set Rng3 = Range(GetTopRange(RngNames, "York", 10)).Offset(0, 6)

    Set Val1 = Rng1.Offset(0, 11)
    Set Val2 = Rng2.Offset(0, 11)
    Set Val3 = Rng3.Offset(0, 11)

    AddChart Rng1, Val1, "London"
    AddChart Rng2, Val2, "Newcastle"
    AddChart Rng3, Val3, "York"

End Sub

Sub AddChart(rLabel As Range, rValues As Range, sTitle As String)
    Dim Cht As Chart
    Set Cht = Charts.Add
    With Cht
        .Name = sTitle
        .ChartType = xlPie
        .SetSourceData Source:=Union(rLabel, rValues)
        '.HasTitle = True
        .ChartTitle.Characters.Text = sTitle
    End With
End Sub

Function GetTopRange(Rng As Range, StrLine As String, NumCount As Long) As String
    Application.Volatile
    Dim Cell As Range, URng As Range
    For Each Cell In Rng.SpecialCells(xlCellTypeConstants)
        If Cell.Value = StrLine Then
            If URng Is Nothing Then
                Set URng = Cell
            Else
                Set URng = Union(URng, Cell)
            End If
            If URng.Cells.Count = NumCount Then
                Exit For
            End If
        End If
    Next Cell
    GetTopRange = URng.Address
End Function

谢谢。