Перебор нескольких таблиц разной длины

ProgramBox

Перебор нескольких таблиц разной длины

Post author:admin
Запись опубликована:27 декабря, 2022
Post category:Вопросы по программированию

#excel #vba #loops #charts #shapes

#excel #vba #циклы #Диаграммы #формы

Вопрос:

У меня есть следующая таблица:

И макрос, который перебирает первый раздел таблицы (строки 6-7), чтобы создать круговые диаграммы справа. Теперь моя цель — также автоматически перебирать все остальные таблицы. Следующая таблица будет в строке 11 и создаст новую круговую диаграмму для этой строки, затем следующую таблицу (строки 15-16) и так далее. Заголовок каждой таблицы всегда красный. Проблема в том, что длина таблиц различается, то есть, например, в table1 («Build», A5: K7) может быть 2 строки, как здесь, или 50, но каждый раз мне нужна одна диаграмма для каждой строки.

В настоящее время у меня есть следующий рабочий код для Table1 («Build» A6: K79) для автоматического создания 2 диаграмм, но я не уверен, как сделать один цикл для всех таблиц на листе.

 Dim rownumber As Integer
Dim LabelRange As Range
Dim ValueRange As Range
Dim Chart As ChartObject
Dim LeftIndent As Long
Dim TopIndent As Long
Dim InhaltsRangeString As String
Dim LetzteZeile As Long

'Intialpositionen für Graphen
LeftIndent = 726
TopIndent = 60
rownumber = 6 'Anfang der Buildtabelle in Reihe 6 (Spalte 1)


Set LabelRange = ThisWorkbook.Worksheets("Testplan Überblick").Range("C5, E5, G5, I5")
Set TPsheet = Worksheets("Testplan Überblick")
Set ValueRange = Union(TPsheet.Cells(rownumber, 3), TPsheet.Cells(rownumber, 5), TPsheet.Cells(rownumber, 7), TPsheet.Cells(rownumber, 9))


'Loop through table 1 which always starts at row 6 (unlike the others which have no set starting point cause the ones before can vary in length!)

For rownumber = 6 To LetzteZeileFunktion Step 1 '"LetzteZeileFunktion" gives me the long value of the last row filled in table 1 

Set Chart = Sheets("Testplan Überblick").ChartObjects.Add(Left:=180, Width:=270, Top:=7, Height:=210)

With Chart
.Chart.SetSourceData Source:=ValueRange
.Chart.ChartType = xlPie
.Chart.HasTitle = True
.Chart.SetElement (msoElementChartTitleAboveChart)
.Chart.ChartTitle.Text = Sheets("Testplan Überblick").Cells(rownumber, 1).Value
.Chart.FullSeriesCollection(1).XValues = LabelRange
.Left = LeftIndent
.Top = TopIndent
.Name = Sheets("Testplan Überblick").Cells(rownumber, 1).Value
End With

TopIndent = TopIndent   225
Next rownumber

End Sub

Любые идеи о том, как перебирать все таблицы, даже если все они могут отличаться по длине (количество строк, заполненных содержимым для диаграмм), будут высоко оценены!
Приветствия

1. Вы можете просто перебрать коллекцию ListObjects — вы найдете много примеров. Вы пробовали это и столкнулись с проблемой?

2. Ах, хорошо, это неправильные таблицы — в этом проблема?

3. Нет, это не правильные таблицы, все просто обычные данные на одном листе, но я просто не уверен, как перебирать их и превращать в диаграммы только те, которые я хочу (а не заголовки для чтения «таблица»)… Я подумал, может быть, перебирать все, пока не будут найдены 2 последовательные пустые строки, затем перейти на 2 ячейки вниз оттуда, и это всегда должно приводить меня к первой строке содержимого новой таблицы…

4. Если первая строка всегда красная, вы можете использовать Find и FindFormat . А еще лучше, преобразуйте их в правильные таблицы.

5. Посмотрите на использование .end(xlDown) , чтобы найти первую ячейку в таблице, а затем `.CurrentRegion. Адрес’

Ответ №1:

Используйте текст в одном из заголовков, чтобы определить начало строк данных и пробел в столбце A до конца. Я использовал «количество тестов» в столбце B.

 Option Explicit

Sub CreateCharts()

    Const DATA = "Testplan Überblick"
    Const ROW_START = 5
    Const POSN_LEFT = 726
    Const POSN_TOP = 60
    Const COL = "B"
    Const HEADER = "testfall qty"

    Dim wb As Workbook, ws As Worksheet
    Dim rngLabel As Range, rngValue As Range
    Dim iRow As Long, iLastRow As Long, count As Integer
    Dim oCht As ChartObject, sColA As String, bflag As Boolean
    bflag = False

    Set wb = ThisWorkbook
    Set ws = wb.Sheets(DATA)
    ' scan down the sheet
    iLastRow = ws.Cells(Rows.count, "A").End(xlUp).Row
    For iRow = ROW_START To iLastRow
        ' look for Testfall Qty as header
        sColA = ws.Cells(iRow, 1)
        If LCase(ws.Cells(iRow, COL)) = HEADER Then
           
            'set ranges
            Set rngLabel = ws.Range("C1, E1, G1, I1").Offset(iRow - 1)
            bflag = True

        ElseIf Len(sColA) > 0 And bflag Then
            ' create chart
            Set rngValue = ws.Range("C1, E1, G1, I1").Offset(iRow - 1)
            
            Set oCht = ws.ChartObjects.Add(Left:=180, _
                      Width:=270, Top:=7, Height:=210)
            With oCht
                .Left = POSN_LEFT
                .Top = POSN_TOP   (count * 255)
                .Name = sColA
                With .Chart
                    .SetSourceData Source:=rngValue
                    .SeriesCollection(1).XValues = rngLabel
                    .ChartType = xlPie
                    .HasTitle = True
                    .SetElement msoElementChartTitleAboveChart
                    .ChartTitle.Text = sColA
                End With
            End With
            count = count   1
        Else
            ' end of chart data
            bflag = False
        End If
    Next
    MsgBox count amp; " Charts created", vbInformation

End Sub