VBA 从分散的数据行创建图表
VBA chart creation from scattered data rows
我正在创建一个 UI 用于输入、编辑、导出、导入患者数据（胆固醇生物标志物）。
我遇到了一个问题，需要显示来自“数据”作品的可用数据sheet。
数据如下所示：
我需要根据 ,, Elizbeth Norton,, 的可用数据创建图表，X 轴为日期，Y 轴为 Chol, Trig, LDL, HDL（单独的线）。
结果是通过使用listBox使用用户形式来管理的（在其中选择数据时，按钮应创建图表。在列表框中选择数据）
此代码找到所需的数据并将选定的结果放入数组
用户表单：
查找所需数据的代码：
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
那么最好的选择是什么？也许改为对 sheet“数据”中的数据进行排序并根据所选范围创建图表？
感谢您的帮助。
一种方法是构建行号集合，然后使用它们为图表的每个系列创建数组。或者将数组转储到另一个 sheet 并将其用作源数据。
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
我正在创建一个 UI 用于输入、编辑、导出、导入患者数据（胆固醇生物标志物）。 我遇到了一个问题，需要显示来自“数据”作品的可用数据sheet。
数据如下所示：
我需要根据 ,, Elizbeth Norton,, 的可用数据创建图表，X 轴为日期，Y 轴为 Chol, Trig, LDL, HDL（单独的线）。
结果是通过使用listBox使用用户形式来管理的（在其中选择数据时，按钮应创建图表。在列表框中选择数据） 此代码找到所需的数据并将选定的结果放入数组
用户表单：
查找所需数据的代码：
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
那么最好的选择是什么？也许改为对 sheet“数据”中的数据进行排序并根据所选范围创建图表？
感谢您的帮助。
一种方法是构建行号集合，然后使用它们为图表的每个系列创建数组。或者将数组转储到另一个 sheet 并将其用作源数据。
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