処理時間を短くする方法はあるかご教授いただきたいです。

Question

約１０万行と２列で構成されるデータのテキストファイルがあります。
そのテキストファイルの内容をコピーしてC、D列に貼り付けます。
そこから「グラフ開始時間」と「グラフ終了時間」に記載した範囲だけをF、G列に貼り付けます。
F列をx軸、G列をy軸として散布図を作っています。

データ自体が多いので仕方ないと思うのですが、それでも処理時間を短くする方法があればご教授いただきたいです！

コードは以下の通りです。

Sub sw_auto_graph()


Dim last  As Long
Dim first_sw_s As Single
Dim first_sw_l As Single
Dim sec_sw_l As Single
Dim sw_max_1 As Single
Dim sw_max_2 As Single

Dim Calstart As Single
Dim Callast As Single
Dim Graph As Variant



    'セルのクリア
    Dim wsActive As Worksheet
    Set wsActive = ActiveSheet
    Range(Cells(2, "C"), Cells(110000, "G")).Clear

    
    Dim txtName As String
    txtName = Application.GetOpenFilename("テキストファイル,*.txt")
    
    If txtName <> "False" Then
        Open txtName For Input As #1
    End If
    
    Dim r As Long
    r = 1 '1行目から書き出す
    
    Do Until EOF(1)
    
        Dim buf As String
        Line Input #1, buf
        
        Dim aryLine As Variant '文字列格納用配列変数
        aryLine = Split(buf, vbTab) '読み込んだ行をタブ区切りで配列変数に格納
        
        Dim i As Long
        For i = LBound(aryLine) To UBound(aryLine)
            'インデックスが0から始まるので列番号に合わせるため+1
            Cells(r + 1, i + 3) = aryLine(i)
        Next
        
        r = r + 1
    
    Loop
    
    Close #1
    
   


start = 1
last = Cells(Rows.Count, "C").End(xlUp).Row



'衝撃波地点探査
first_sw_s = Cells(10, "B").Value '第一衝撃波の開始点
first_sw_l = Cells(12, "B").Value '第一衝撃波の終点
sec_sw_l = Cells(14, "B").Value '第二衝撃波の終点

For i = 2 To last
    If Cells(i, "C").Value * 1000000 >= first_sw_s Then
        s = i
        Exit For
    End If
Next
For i = s To last
    If Cells(i, "C").Value * 1000000 >= first_sw_l Then
        t = i
        Exit For
    End If
Next
For i = t To last
    If Cells(i, "C").Value * 1000000 >= sec_sw_l Then
        u = i
        Exit For
    End If
Next

'------------------------------------------------------------------------------------------------------

sw_max_1 = WorksheetFunction.Max(Range(Cells(s, "D"), Cells(t, "D")))
sw_max_2 = WorksheetFunction.Max(Range(Cells(t, "D"), Cells(u, "D")))
sw_min = WorksheetFunction.Min(Range(Cells(t, "D"), Cells(u, "D")))
Cells(17, "A").Value = sw_max_1
Cells(19, "A").Value = sw_max_2
Cells(21, "A").Value = sw_min

For i = 2 To last
    If Cells(i, "D").Value = sw_min Then
        Cells(21, "B").Value = Cells(i, "C") * 1000000
    End If
Next
For i = 2 To last
    If Cells(i, "D").Value = sw_max_1 Then
        Cells(17, "B").Value = Cells(i, "C") * 1000000
    End If
Next

For i = 2 To last
    If Cells(i, "D").Value = sw_max_2 Then
        Cells(19, "B").Value = Cells(i, "C") * 1000000
    End If
Next

'------------------------------------------------------------------------------------------------------

Calstart = Cells(6, "B").Value
Callast = Cells(8, "B").Value

If Callast > Cells(last, "C") * 1000000 Then
MsgBox "グラフ終了時間が取得したデータの範囲外です。「終了」を押して値を減らしてください。"
End If

If Calstart < Cells(2, "C") * 1000000 Then
MsgBox "グラフ開始時間が取得したデータの範囲外です。「終了」を押して値を増やしてください。"
End If


For i = 2 To last
    If Cells(i, "C").Value * 1000000 >= Calstart Then
        Calstart = i
        Exit For
    End If
Next
For k = Calstart To last
    If Cells(k, "C").Value * 1000000 >= Callast Then
        Callast = k
        Exit For
    End If
Next

n = Callast - Calstart
j = 0

ReDim Graph(n, 1)
For h = Calstart To Callast
Graph(j, 0) = Cells(h, "C").Value * 1000000
Graph(j, 1) = Cells(h, "D").Value
j = j + 1
Next
Range("F2").Resize(n + 1, 2) = Graph
    

 ' グラフの位置
    gpos_x = 300
    gpos_y = 50
    
    ' グラフのサイズ
    g_width = 800
    g_height = 300
graph_name = "my_graph"

y_offset = 2
x_offset = 7
series_num = 1
chart_title = "Pressure"
x_title = "Time[μs]"
y_title = "Pressure[MPa]"



   ' アクティブシート上に既存のグラフがあれば削除
    If ActiveSheet.ChartObjects.Count > 0 Then
        For i = 1 To ActiveSheet.ChartObjects.Count
            ' グラフ名が一致するか
            If ActiveSheet.ChartObjects(i).Name = graph_name Then
                ActiveSheet.ChartObjects(i).Delete
                Exit For
            End If
        Next i
    End If
    
    
    ' データ範囲を決定 (何行目まであるのか)
    y_temp = y_offset
    continue_flag = True
    Do While continue_flag = True
        ' この行に内容があれば次の行へ進む
        If Len(Cells(y_temp, x_offset).Value) > 0 Then
            y_temp = y_temp + 1
        Else
            continue_flag = False
        End If
    Loop
    y_end = y_temp
    x_end = x_offset + series_num - 1
    
    
   
    Dim chartObj As ChartObject
    Set chartObj = ActiveSheet.ChartObjects.Add( _
        gpos_x, gpos_y, g_width, g_height _
    )
    chartObj.Name = graph_name
    With chartObj.Chart
        
        ' データ範囲をセット（左上と右下）
        .SetSourceData ActiveSheet.Range( _
            Cells(y_offset, x_offset), _
            Cells(y_end, x_end) _
        ), xlColumns
        
        ' x軸の項目軸範囲をセット
        .SeriesCollection(1).XValues = Range( _
            Cells(y_offset, x_offset - 1), _
            Cells(y_end, x_offset - 1) _
        )
        
        ' オプションをセット
        .ChartType = xlXYScatter ' 散布図
        .HasTitle = True
        .ChartTitle.Characters.Text = chart_title
        .Axes(xlcategory, xlPrimary).HasTitle = True
        .Axes(xlcategory, xlPrimary).AxisTitle.Characters.Text = x_title
        .Axes(xlValue, xlPrimary).HasTitle = True
        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = y_title
        .Axes(xlcategory).MajorUnit = 5
        .Axes(xlcategory).MinimumScale = Cells(6, "B").Value
        .Axes(xlcategory).MaximumScale = Cells(8, "B").Value

        
        
       

    End With
    
     With ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
        .MarkerStyle = xlNone 'マーカーを非表示
        
        End With
    With ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1).Format.Line
        .DashStyle = msoLineSolid '実線にする
        .Weight = 0.25
        .ForeColor.RGB = RGB(0, 0, 255)


    End With

 ActiveSheet.ChartObjects(1).Chart.HasLegend = False

ActiveSheet.ChartObjects(1).Chart.Axes(xlValue, 1).AxisTitle.Font.Color = RGB(0, 0, 0) '文字色
ActiveSheet.ChartObjects(1).Chart.Axes(xlValue, 1).AxisTitle.Font.Size = 18 '文字サイズ

ActiveSheet.ChartObjects(1).Chart.Axes(xlcategory, 1).AxisTitle.Font.Color = RGB(0, 0, 0) '文字色
ActiveSheet.ChartObjects(1).Chart.Axes(xlcategory, 1).AxisTitle.Font.Size = 18 '文字サイズ


Dim chtobj As Object

For Each chtobj In ActiveSheet.ChartObjects

    With chtobj.Chart.Axes(xlValue, xlPrimary)
         .TickLabelPosition = xlLow
    End With
    
    With chtobj.Chart.Axes(xlcategory, xlPrimary)
         .TickLabelPosition = xlLow
    End With
    
  
Next



End Sub

Comments

[jinoji]

なかなかに長いコードですが、まずはどのあたりで時間が掛かっているか計測してみるのはどうですか？

[inoue-ryosuke-f]

調べてみたところ、テキストファイルからコピーして貼り付けるところに時間がかかっていました（２９秒）
グラフの作成自体は７秒でした！
何かいい方法はないでしょうか？

Answer 1

とりあえずこうするだけでも多少はマシになると思います。

        'For i = LBound(aryLine) To UBound(aryLine)
        '    Cells(r + 1, i + 3) = aryLine(i)
        'Next
        Cells(r + 1, 3).Resize(, UBound(aryLine) + 1) = aryLine

Answer 2

セルに一個ずつデータを入れているので遅いのだと推測します。
行、列ともに1から始まる2次元配列を用意してそこにデータを保存していき最後にセルに代入した方が早いと思います。
例

Dim v() as Variant
Dim rowCount as Integer
Dim columnCount as Integer
'行列数を取得する処理をする
Redim v(1 to rowCount, 1 to columnCount) '2次元配列を動的に確保 詳しくは「vba 2次元配列 redim」 などで検索してください。
For row = 1 To rowCount
  For col = 1 To columnCount
    v(row, col) = 'データを代入
  Next
Next

Dim ra as Range
Set ra = Range("A1").Resize(rowCount, colCount) 'データを入れたいセル範囲を取得
ra.Value = v '一気に入力