从分散的数据行创建 VBA 图表

Question

我正在创建一个用于输入、编辑、导出和导入患者数据（胆固醇生物标志物）的 UI。 我遇到了需要显示“数据”工作表中可用数据的问题。

数据如下所示：

我需要从,, Elizbeth Norton,, 的可用数据创建一个图表，X 轴为日期，Y 轴为Chol, Trig, LDL, HDL（单独的线）。

通过使用listbox的UserForm来管理结果（在选择数据时，按钮应从该按钮应在其中创建图表。在列表框中选择了数据） 这段代码会找到需要的数据并将选定的结果放入一个数组中

用户表单：

查找所需数据的代码：

If Len(f_FindAll.TextBox_Find.Value) >= 3 Then 'Do search if text in find box is longer than 3 character.
    
    Set SearchRange = ActiveWorkbook.Worksheets("Data").Range("C:E").Cells
    
    FindWhat = f_FindAll.TextBox_Find.Value
    'Calls the FindAll function
    Set FoundCells = FindAll(SearchRange:=SearchRange, _
                            FindWhat:=FindWhat, _
                            LookIn:=xlValues, _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByColumns, _
                            MatchCase:=False, _
                            BeginsWith:=vbNullString, _
                            EndsWith:=vbNullString, _
                            BeginEndCompare:=vbTextCompare)
    If FoundCells Is Nothing Then
        ReDim arrResults(1 To 1, 1 To 5)
        arrResults(1, 1) = "Data not found!!!"

    Else
        'Add results of FindAll to an array
        ReDim arrResults(1 To FoundCells.Count, 1 To 5)
        lFound = 1
         For Each FoundCell In FoundCells
            If FoundCell.Column = 3 Then
                arrResults(lFound, 1) = FoundCell.Offset(0, -1).Value
                arrResults(lFound, 2) = FoundCell.Value
                arrResults(lFound, 3) = FoundCell.Offset(0, 1).Value
                arrResults(lFound, 4) = FoundCell.Offset(0, 2).Value
                arrResults(lFound, 5) = FoundCell.Address
                lFound = lFound + 1
            Else
                If FoundCell.Column = 4 Then
                    arrResults(lFound, 1) = FoundCell.Offset(0, -2).Value
                    arrResults(lFound, 2) = FoundCell.Offset(0, -1).Value
                    arrResults(lFound, 3) = FoundCell.Value
                    arrResults(lFound, 4) = FoundCell.Offset(0, 1).Value
                    arrResults(lFound, 5) = FoundCell.Address
                    lFound = lFound + 1
                Else
                    If FoundCell.Column = 5 Then
                        arrResults(lFound, 1) = FoundCell.Offset(0, -3).Value
                        arrResults(lFound, 2) = FoundCell.Offset(0, -2).Value
                        arrResults(lFound, 3) = FoundCell.Offset(0, -1).Value
                        arrResults(lFound, 4) = FoundCell.Value
                        arrResults(lFound, 5) = FoundCell.Address
                        lFound = lFound + 1
                    End If
                End If
            End If
            
        Next FoundCell
    End If
    
    'Populate the listbox with the array
    Me.ListBox_Results.List = arrResults

在用户表单中显示所选数据的代码：

Private Sub ListBox_Results_Click()
'Go to selection on the sheet when the result is clicked

Dim strAddress As String
Dim l As Integer

    For l = 0 To ListBox_Results.ListCount
        If ListBox_Results.Selected(l) = True Then
            strAddress = ListBox_Results.List(l, 4)
            Rownum = Range(strAddress).Row
            Colnum = Range(strAddress).Column
            ActiveWorkbook.Worksheets("Data").Select
            Cells(Rownum, Colnum).Select
            'Populate textboxes with results
            'and maybe populate chart data range with results aswell????
            With ActiveWorkbook.Worksheets("Data")
                f_FindAll.TextBox_Results1.Value = .Cells(.Range(strAddress).Row, 1).Value
                f_FindAll.TextBox_Results2.Value = .Cells(.Range(strAddress).Row, 2).Value
                f_FindAll.TextBox_Results3.Value = .Cells(.Range(strAddress).Row, 3).Value
                f_FindAll.TextBox_Results4.Value = .Cells(.Range(strAddress).Row, 4).Value
                f_FindAll.TextBox_Results5.Value = .Cells(.Range(strAddress).Row, 5).Value
                f_FindAll.TextBox_Results6.Value = .Cells(.Range(strAddress).Row, 6).Value
                f_FindAll.TextBox_Results7.Value = .Cells(.Range(strAddress).Row, 7).Value
                f_FindAll.TextBox_Results8.Value = .Cells(.Range(strAddress).Row, 8).Value
                f_FindAll.TextBox_Results9.Value = .Cells(.Range(strAddress).Row, 9).Value
                f_FindAll.TextBox_Results10.Value = .Cells(.Range(strAddress).Row, 10).Value
                f_FindAll.TextBox_Results11.Value = .Cells(.Range(strAddress).Row, 11).Value
                f_FindAll.TextBox_Results12.Value = .Cells(.Range(strAddress).Row, 12).Value
            End With
            GoTo EndLoop
        End If
    Next l

EndLoop:
    
End Sub

那么最好的选择是什么？也许改为对工作表“数据”中的数据进行排序并从所选范围创建图表？

感谢您的帮助。

Answer 1

一种方法是构建行号集合，然后使用它们为图表的每个系列创建数组。或者将数组转储到另一个工作表并将其用作源数据。

Option Explicit

Sub PlotData()

    Dim wb As Workbook, ws As Worksheet
    Dim rngSearch As Range, rngFound As Range
    Dim FindWhat As String, FirstFound As String
    Dim datarows As Collection, ar
    Dim r As Long, i As Integer, n As Integer
    
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Data")
    Set datarows = New Collection
    Set rngSearch = ws.UsedRange.Columns("C:E")

    ' build collection of rows
    FindWhat = "11342"
    Set rngFound = rngSearch.Find(FindWhat, _
                    LookIn:=xlValues, LookAt:=xlPart, _
                    SearchOrder:=xlByColumns, MatchCase:=False)
    
    If rngFound Is Nothing Then
        ' no match
        Exit Sub
    Else
        FirstFound = rngFound.Address
        Do
            n = n + 1
            datarows.Add rngFound.Row, CStr(n)
            Set rngFound = rngSearch.FindNext(After:=rngFound)
        Loop While Not rngFound Is Nothing And rngFound.Address <> FirstFound
    End If

    ' fill array
    ReDim ar(1 To n, 1 To 5), x(n - 1), y(n - 1)
    Dim sname
    sname = Array("date", "chol", "trig", "LDL", "HDL")
    For i = 1 To n
        With ws
           r = datarows(i)
           x(i - 1) = .Cells(r, "B") 'date
           ar(i, 1) = .Cells(r, "B") 'date
           ar(i, 2) = .Cells(r, "I") 'chol
           ar(i, 3) = .Cells(r, "J") 'trig
           ar(i, 4) = .Cells(r, "K") 'LDL
           ar(i, 5) = .Cells(r, "L") 'HDL
        End With
    Next

    ' copy to sheet if required as source data for plot
    'Sheet2.Range("A1:E1") = sname
    'Sheet2.Range("A2:E" & n + 1) = ar

    ' plot graph
    Dim cht As Chart, c As Integer, srs As Series
    Set cht = ws.Shapes.AddChart(xlLineMarkers).Chart
    With cht
        .HasTitle = True
        .ChartTitle.Text = FindWhat
        For c = 2 To 5
            'Define the array of values for each series
            For i = 1 To n
                y(i - 1) = ar(i, c)
            Next
            Set srs = .SeriesCollection.NewSeries
            With srs
                .XValues = x
                .Values = y
                .name = sname(c - 1)
            End With
        Next
        .Location Where:=xlLocationAsNewSheet, name:=FindWhat
    End With

    MsgBox "Done"
End Sub