实现对文件夹中的涨停数据给出历史30天数据的折线图

利用周末两天实现了查看股票中历史折线信息的VBA程式。将VBA文档和股票历史数据放在F盘根目录下fiance文件夹中，股票历史数据取第一列为时间横轴，第四列为当日收盘，第11列为当日换手率。两条折线。。针对每个涨停折线图停留时间为3秒。

数据文件格式如下：

结果图如下：

 

Sub showLine()
Dim s As FileSearch
Dim Workbook, dataExcel, newSheet
Dim fileNum As Integer
Dim jRows, totalFile, totalRows, copyNum, totalNum2, realNum As Integer
Dim ch As ChartObject
Dim rng1, rng2, rng3 As Range
Dim testvalue1, testvalue2

testvalue1 = 0
Set s = Application.FileSearch
s.LookIn = "F:\finace"
s.Filename = "*.*"
s.Execute

totalFile = s.FoundFiles.Count
Set dataExcel = CreateObject("Excel.Application")

'如下针对每个文件进行画折线图

For i = 1 To totalFile
Cells(i, 1) = s.FoundFiles(i)
Cells(1, 6) = s.FoundFiles(i)
Set Workbook = dataExcel.Workbooks.Open(s.FoundFiles(i))
Set newSheet = Workbook.Sheets(1)

totalRows = newSheet.UsedRange.Rows.Count
For jRows = 2 To totalRows

If newSheet.Cells(jRows, 10) > 9.9 And jRows + 35 < totalRows And newSheet.Cells(jRows, 10) <> "None" Then

realNum = 0
Cells(1, 7) = newSheet.Cells(jRows, 1)
Cells(1, 8) = newSheet.Cells(jRows, 4)

For copyNum = 30 To 1 Step -1
If newSheet.Cells(jRows + copyNum - 1, 4).Value <> 0 Then

realNum = realNum + 1
Sheets("Sheet2").Cells(realNum, 1) = newSheet.Cells(jRows + copyNum - 1, 1)
Sheets("Sheet2").Cells(realNum, 4) = newSheet.Cells(jRows + copyNum - 1, 4)
Sheets("Sheet2").Cells(realNum, 11) = newSheet.Cells(jRows + copyNum - 1, 11)
End If

Next
Set rng1 = Worksheets("Sheet2").Range("a1:a" & realNum)
Set rng2 = Worksheets("Sheet2").Range("d1:d" & realNum)
Set rng3 = Worksheets("Sheet2").Range("k1:k" & realNum)
If WorksheetFunction.Max(rng2.Value) - WorksheetFunction.Min(rng2.Value) <> 0 And WorksheetFunction.Max(rng2.Value) <> 0 Then
'画折线图
On Error GoTo err:
Worksheets("Sheet1").ChartObjects("收盘和换手率").Delete
err:

Set ch = Worksheets("Sheet1").ChartObjects.Add(80, 20, 800, 400)
ch.Name = "收盘和换手率"

With ch.Chart
            .ChartType = xlLine
            .SeriesCollection.NewSeries
            .SeriesCollection(1).Values = rng2
            .SeriesCollection(1).XValues = rng1
            .SeriesCollection(1).Name = "收盘价"
            .SeriesCollection.NewSeries
            .SeriesCollection(2).Values = rng3
            .SeriesCollection(2).XValues = rng1
            .SeriesCollection(2).Name = "换手率"
End With
   ch.Chart.SeriesCollection(1).AxisGroup = 1
   ch.Chart.SeriesCollection(1).MarkerStyle = xlNone
   ch.Chart.SeriesCollection(2).AxisGroup = 2
   ch.Chart.SeriesCollection(2).MarkerStyle = xlNone
With ch.Chart.Axes(xlValue, xlPrimary)
             .MajorUnit = (WorksheetFunction.Max(rng2.Value) - WorksheetFunction.Min(rng2.Value)) / 10
             .MaximumScale = WorksheetFunction.Max(rng2.Value) + (.MajorUnit) * 2
             .MinimumScale = WorksheetFunction.Min(rng2.Value) - (.MajorUnit) * 2
             .CrossesAt = .MinimumScale
             .TickLabels.Font.Size = 8
End With
With ch.Chart.Axes(xlValue, xlSecondary)
             .MajorUnit = (WorksheetFunction.Max(rng3.Value) - WorksheetFunction.Min(rng3.Value)) / 10
             .MaximumScale = WorksheetFunction.Max(rng3.Value) + (.MajorUnit) * 2
             .MinimumScale = WorksheetFunction.Min(rng3.Value) - (.MajorUnit) * 2
             .CrossesAt = .MinimumScale
             .TickLabels.Font.Size = 8
End With
With ch.Chart.Axes(xlCategory).TickLabels
        .Font.Size = 8
        .NumberFormatLocal = "yy-m-d"
End With
Set rng1 = Nothing
Set rng2 = Nothing
Set rng3 = Nothing
Set ch = Nothing

Application.Wait (Now + TimeValue("00:00:02"))

End If

'画折线图

ElseIf newSheet.Cells(jRows, 10) > 9.9 And jRows < totalRows - 3 And newSheet.Cells(jRows, 10) <> "None" Then

totalNum2 = totalRows - jRows
realNum = 0

Cells(1, 7) = newSheet.Cells(jRows, 1)
Cells(1, 8) = newSheet.Cells(jRows, 4)

For copyNum = totalNum2 To 1 Step -1

If newSheet.Cells(jRows + copyNum - 1, 4).Value <> 0 Then
realNum = realNum + 1
Sheets("Sheet2").Cells(realNum, 1) = newSheet.Cells(jRows + copyNum - 1, 1)
Sheets("Sheet2").Cells(realNum, 4) = newSheet.Cells(jRows + copyNum - 1, 4)
Sheets("Sheet2").Cells(realNum, 11) = newSheet.Cells(jRows + copyNum - 1, 11)
End If
Next

If realNum < 10 Then
Set rng1 = Worksheets("Sheet2").Range("a1:a10")
Set rng2 = Worksheets("Sheet2").Range("d1:d10")
Set rng3 = Worksheets("Sheet2").Range("k1:k10")
Else
Set rng1 = Worksheets("Sheet2").Range("a1:a" & realNum)
Set rng2 = Worksheets("Sheet2").Range("d1:d" & realNum)
Set rng3 = Worksheets("Sheet2").Range("k1:k" & realNum)

End If
If WorksheetFunction.Max(rng2.Value) - WorksheetFunction.Min(rng2.Value) <> 0 And WorksheetFunction.Max(rng2.Value) <> 0 Then
'画折线图
On Error GoTo err2:
Worksheets("Sheet1").ChartObjects("收盘和换手率").Delete
err2:
Set ch = Worksheets("Sheet1").ChartObjects.Add(80, 20, 800, 400)
ch.Name = "收盘和换手率"
With ch.Chart
            .ChartType = xlLine
            .SeriesCollection.NewSeries
            .SeriesCollection(1).Values = rng2
            .SeriesCollection(1).XValues = rng1
            .SeriesCollection(1).Name = "收盘价"
            .SeriesCollection.NewSeries
            .SeriesCollection(2).Values = rng3
            .SeriesCollection(2).XValues = rng1
            .SeriesCollection(2).Name = "换手率"
End With
   ch.Chart.SeriesCollection(1).AxisGroup = 1
   ch.Chart.SeriesCollection(1).MarkerStyle = xlNone
   ch.Chart.SeriesCollection(2).AxisGroup = 2
   ch.Chart.SeriesCollection(2).MarkerStyle = xlNone
 
With ch.Chart.Axes(xlValue, xlPrimary)
             .MajorUnit = (WorksheetFunction.Max(rng2.Value) - WorksheetFunction.Min(rng2.Value)) / 10
             .MaximumScale = WorksheetFunction.Max(rng2.Value) + (.MajorUnit) * 2
             .MinimumScale = WorksheetFunction.Min(rng2.Value) - (.MajorUnit) * 2
             .CrossesAt = .MinimumScale
             .TickLabels.Font.Size = 8
End With
With ch.Chart.Axes(xlValue, xlSecondary)
             .MajorUnit = (WorksheetFunction.Max(rng3.Value) - WorksheetFunction.Min(rng3.Value)) / 10
             .MaximumScale = WorksheetFunction.Max(rng3.Value) + (.MajorUnit) * 2
             .MinimumScale = WorksheetFunction.Min(rng3.Value) - (.MajorUnit) * 2
             .CrossesAt = .MinimumScale
             .TickLabels.Font.Size = 8
End With
With ch.Chart.Axes(xlCategory).TickLabels
        .Font.Size = 8
        .NumberFormatLocal = "yy-m-d"
End With
Set rng1 = Nothing
Set rng2 = Nothing
Set rng3 = Nothing
Set ch = Nothing

Application.Wait (Now + TimeValue("00:00:02"))

End If

'画折线图

End If
Next

Workbook.Save
Workbook.Close

Next

End Sub