Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 7 Professional : Excel 2013)
処理速度改善のご相談
投稿日時: 19/05/16 17:14:32
投稿者: current

いつもお世話になっております。先日もご相談させていただいておりますが、下記コードの速度アップのためまだ多く存在しますが、selectを減少するためにコード修正をしています。
本日下記まで修正しましたが、思ったより速度が速くなっていませんでした。全体の半分がこのコードで消費されていますので、少なくとも現状の半分を目安に改善していこうと思っています。
恐れ入りますが、気になった点からで構いませんので改善方法をご教授いただければと思います。
よろしくお願いいたします。
 

Option Explicit

option explict

Sub chart_data_collecting()

    Dim paste_cell As Long, number_of_sample As Long, original_chart_data As Long, number_of_sample2 As Long, number_of_find As Long
    Dim i As Long, j As Long, n As Long, x As Long, y As Long, z As Long, hh As Long, ee As Long, cc As Long
    Dim dd As Double
    
    paste_cell = 18
    number_of_sample = Range("C8").Value
    Range("c1").Select
    For original_chart_data = 1 To number_of_sample
        For number_of_find = 1 To original_chart_data
            Cells.Find(What:="スト", after:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , MatchByte:=False, SearchFormat:=False).Activate
        Next number_of_find
        ActiveCell.Offset(2, 1).Select
        Calculate
        Range(Selection, Selection.Offset(0, -1).End(xlDown)).Copy
        Cells(2, paste_cell).PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
        :=False, Transpose:=False
        paste_cell = paste_cell + 2
    Next original_chart_data
    paste_cell = 18
    For n = 1 To number_of_sample * 2
        If Cells(2, paste_cell).Value <> "" Then
            Cells(1, paste_cell) = "N" & n
            paste_cell = paste_cell + 1
        End If
    Next n
    paste_cell = 18
    Range("R1").Select
    Range(Selection, Selection.End(xlToRight)).Copy
    Cells(1, number_of_sample * 2 + 18).PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
    :=False, Transpose:=False
    For x = 1 To number_of_sample
        ActiveCell.Offset(1, 0) = "=IF(RC[" & -number_of_sample * 2 + 1 & "]>" & Worksheets("main").Range("G14").Value & ",RC[" & -number_of_sample * 2 & "],"""")"
        ActiveCell.Offset(1, 1) = "=IF(RC[" & -number_of_sample * 2 & "]>" & Worksheets("main").Range("G14").Value & ",RC[" & -number_of_sample * 2 & "],"""")"
        ActiveCell.Offset(1, 0).Select
        Range(Selection, Selection.Offset(0, 1)).Copy
        Cells(1, paste_cell).End(xlDown).Offset(0, number_of_sample * 2).Select
        Range(Selection, Selection.End(xlUp)).PasteSpecial Paste:=xlPasteFormulas, operation:=xlNone, skipblanks _
        :=False, Transpose:=False
        ActiveCell.Offset(-1, 2).Select
        paste_cell = paste_cell + 2
    Next x
    Calculate
    Columns("R:R").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
    :=False, Transpose:=False
    number_of_sample2 = Range("C8").Value * 2
    For y = 1 To number_of_sample2
        Columns(18 + number_of_sample2).Select
        Selection.TextToColumns Destination:=Cells(1, 18 + number_of_sample2), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
        number_of_sample2 = number_of_sample2 + 1
    Next y
    Columns("R:R").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.Delete Shift:=xlUp
    z = 1
    number_of_sample2 = Range("C8").Value * 2
    Cells(1, 18 + number_of_sample * 4).Select
    For i = 1 To number_of_sample
        ActiveCell = "N" & z
        z = z + 1
        ActiveCell.Offset(0, 1) = "N" & z
        z = z + 1
        ActiveCell.Offset(1, 0).Select
        ActiveCell.FormulaR1C1 = "= rc[" & -number_of_sample2 & "]-r2c[" & -number_of_sample2 & "]"
        ActiveCell.Offset(0, 1).Select
        ActiveCell.FormulaR1C1 = "= rc[" & -number_of_sample2 & "]"
        Range(Selection, Selection.Offset(0, -1)).Copy
        ActiveCell.Offset(0, -number_of_sample2 - 1).Select
        Selection.End(xlDown).Select
        ActiveCell.Offset(0, number_of_sample2).Select
        Range(Selection, Selection.End(xlUp)).Select
        ActiveSheet.Paste
        ActiveCell.Offset(-1, 2).Select
    Next i
    hh = 16 + number_of_sample - 1
    ee = 18 + number_of_sample2 * 2
    Calculate
    For j = 1 To number_of_sample
        dd = Application.Round(Cells(hh, 15), 6)
        cc = Columns(ee + 1).Find(What:=dd, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns).Row
        Cells(hh, 16) = Cells(cc, ee).Value
        ee = ee + 2
        hh = hh + 1
    Next j
End Sub

回答
投稿日時: 19/05/16 18:08:50
投稿者: WinArrow
投稿者のウェブサイトに移動

殆ど「Select」「Activate」が付いたまま・・・・
まず、単純に外したら・・・全部外すのではなく、
最初の1つ〜2つ外してみて、どのようになるのか確認するとよいでしょう。
 
前のトピでも回答したが
>Calculate
は、開いているブック全部が再計算対象になります。
セル範囲を限定するようお勧めします。
 
 

回答
投稿日時: 19/05/16 21:39:32
投稿者: simple

まず、
(1)3カ所にあるCalculateをコメントにしてしまって、
(2)プロシージャーの最初で
    Application.Calculation = xlCalculationManual
   最後で
    Application.Calculation = xlCalculationAutomatic
として、実行時間がどの程度変わるか教えて下さい。
 
以前のスレッドで、

引用:
レイアウトが提示されてでもいれば別ですが、
コードを元にレイアウトをこちらで想像して改善したコードを提示するようなことは、
お互いに生産的ではないので、期待されないほうがよいと思います。
と書きました。その考えは今も変わりません。
 
ご自分でSelectを使わないコードを書く気はなく、他人に答えをリクエストするなら、
少なくとも、シートのレイアウトを説明して貰いたいですね。
そして、各ブックで、レイアウトにどの程度の差異があるのかも示して貰いたい。
そうすれば回答が寄せられると思います。

回答
投稿日時: 19/05/16 22:29:28
投稿者: baoo

皆さんが言うようにSelectやActivateの問題もそうなのですが、
問題の大本はコードの一文一文の意味を吟味していないように思えます。
 
例えば、For Nextが何回か出てきますがループの中でカウンターが殆ど使われておらず、
その代わりに別の変数を+1や+2していたりします。
For Nextの意味を吟味していれば別の変数を使う必要は無いと思います。
 
他にも例えば下記コードの中にあるSelectionとは何でしょう?
SelectやSelectionという英単語の意味は考えていますか?

    Columns("R:R").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
    :=False, Transpose:=False
それを考えていればこんなコードにはならない筈です。
 
大変頑張っておられるのは分かるのですが、1つ1つの意味を考えて、
変数はなるたけ少なくて済むように、コードも少なくて済むようにすることが、
結果的に速度アップや不具合を減らすことになります。
 
ちなみにSelectやActivate、ActiveCellなど私なら殆ど使うことのない部分を
コメントアウトしたら35行に上りました。
すべてSelect、Selection、Activate、ActiveCellを使わないコードに書き換えてみましょう。

投稿日時: 19/05/17 14:12:06
投稿者: current

皆様、大変お世話になっております。いつも的確なアドバイスありがとうございます。
取り急ぎ、calculationの影響を確認しました。コメントにした場合とそうでない時で比較すると約1秒ほど差がありました。そのため、セル範囲限定を進めたいと思います。
 
オリジナル15.25781
コメント14.42969
 
レイアウトの提示につきましてもご指摘の通りと思いますので、可能な限り提示させていただくことを検討しております。
 
下記、具体的にどのようなことでしょうか?
正しく理解したいので、大変恐縮になりますが、ご教示お願いいたします。
 

引用:
例えば、For Nextが何回か出てきますがループの中でカウンターが殆ど使われておらず、
その代わりに別の変数を+1や+2していたりします。
For Nextの意味を吟味していれば別の変数を使う必要は無いと思います。
 
他にも例えば下記コードの中にあるSelectionとは何でしょう?
SelectやSelectionという英単語の意味は考えていますか?
 
    Columns("R:R").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
    :=False, Transpose:=False
 
それを考えていればこんなコードにはならない筈です。

回答
投稿日時: 19/05/17 16:24:35
投稿者: Suzu

引用:
下記、具体的にどのようなことでしょうか?
正しく理解したいので、大変恐縮になりますが、ご教示お願いいたします。
 
引用:
例えば、For Nextが何回か出てきますがループの中でカウンターが殆ど使われておらず、
その代わりに別の変数を+1や+2していたりします。
For Nextの意味を吟味していれば別の変数を使う必要は無いと思います。
 
他にも例えば下記コードの中にあるSelectionとは何でしょう?
SelectやSelectionという英単語の意味は考えていますか?
 
    Columns("R:R").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
    :=False, Transpose:=False
 
それを考えていればこんなコードにはならない筈です。

 
Select、Selection を使用するのは、
Excel のマクロの自動記録 を参考にしたときの弊害でもあるのですが、
 
 「セルを選択する」のに、 Select
 「選択された セル」に対し操作をする場合、その選択されたセルを Selection
   として、表記します。
 
  マクロの自動記録の流れとして、
   「セル選択」
     ↓
   「選択されたセルに対して操作」
    が記録されます。
 
が、
操作はセルに対し操作するのであって、選択されたセルでなければ操作できないという話ではないです。
引用:
Columns("R:R").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks 〜〜〜〜

 
は、
With Range(Columns("R:R"), Columns("R:R").End(xlToRight))
  .Copy
  .PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
End With
 
で十分です。
 
場合によっては、
Range(Columns("R:R"), Columns("R:R").End(xlToRight)).Value = Range(Columns("R:R"), Columns("R:R").End(xlToRight)).Value
でも可能かもしれません。

投稿日時: 19/05/17 16:36:49
投稿者: current

calculateの範囲指定やselectionの減少などコード修正いたしました。結果3.9秒になりました。まだまだ無駄がありますし、もう少し改善したいので、引き続きご指導よろしくお願いいたします。
 

Option Explicit

Sub chart_data_collecting()

    Dim paste_cell As Long, number_of_sample As Long, original_chart_data As Long, number_of_sample2 As Long, number_of_find As Long
    Dim i As Long, j As Long, n As Long, x As Long, y As Long, z As Long, hh As Long, ee As Long, cc As Long
    Dim dd As Double
    Dim CR As String, NR As String
    
    'Application.calculation = xlCalculationAutomatic
    paste_cell = 18
    number_of_sample = Range("C8").Value
    Range("c1").Select
    For original_chart_data = 1 To number_of_sample
        For number_of_find = 1 To original_chart_data
            Cells.Find(What:="ストローク/stress", after:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , MatchByte:=False, SearchFormat:=False).Activate
        Next number_of_find
        ActiveCell.Offset(2, 1).Select
        CR = Range(Selection, Selection.Offset(0, -1).End(xlDown)).Address
        Range(CR).Copy
        Cells(2, paste_cell).PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
        :=False, Transpose:=False
        paste_cell = paste_cell + 2
    Next original_chart_data
    paste_cell = 18
    For n = 1 To number_of_sample * 2
        If Cells(2, paste_cell).Value <> "" Then
            Cells(1, paste_cell) = "N" & n
            paste_cell = paste_cell + 1
        End If
    Next n
    paste_cell = 18
    'Range("R1").Select
    NR = Range("R1").Resize(, number_of_sample * 2).Address
    Range(NR).Copy
    Cells(1, 18 + number_of_sample * 2).PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
        :=False, Transpose:=False
    'Range(Selection, Selection.End(xlToRight)).Copy
    'Cells(1, number_of_sample * 2 + 18).PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
    :=False, Transpose:=False
    For x = 1 To number_of_sample
        ActiveCell.Offset(1, 0) = "=IF(RC[" & -number_of_sample * 2 + 1 & "]>" & Worksheets("main").Range("G14").Value & ",RC[" & -number_of_sample * 2 & "],"""")"
        ActiveCell.Offset(1, 1) = "=IF(RC[" & -number_of_sample * 2 & "]>" & Worksheets("main").Range("G14").Value & ",RC[" & -number_of_sample * 2 & "],"""")"
        ActiveCell.Offset(1, 0).Select
        Range(Selection, Selection.Offset(0, 1)).Copy
        Cells(1, paste_cell).End(xlDown).Offset(0, number_of_sample * 2).Select
        Range(Selection, Selection.End(xlUp)).PasteSpecial Paste:=xlPasteFormulas, operation:=xlNone, skipblanks _
        :=False, Transpose:=False
        ActiveCell.Offset(-1, 2).Select
        paste_cell = paste_cell + 2
    Next x
    CR = Range("R1").CurrentRegion.Address
    Range(CR).Calculate
    Range(CR).Copy
    Range("R1").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
    :=False, Transpose:=False
    number_of_sample2 = Range("C8").Value * 2
    For y = 1 To number_of_sample2
        Columns(18 + number_of_sample2).Select
        Selection.TextToColumns Destination:=Cells(1, 18 + number_of_sample2), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
        number_of_sample2 = number_of_sample2 + 1
    Next y
    If WorksheetFunction.CountBlank(Range(CR)) <> 0 Then
        Range(CR).SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
    End If
    'Columns("R:R").Select
    'Range(Selection, Selection.End(xlToRight)).Select
    'Selection.SpecialCells(xlCellTypeBlanks).Select
    'Selection.Delete shift:=xlUp
    z = 1
    number_of_sample2 = Range("C8").Value * 2
    Cells(1, 18 + number_of_sample * 4).Select
    For i = 1 To number_of_sample
        ActiveCell = "N" & z
        z = z + 1
        ActiveCell.Offset(0, 1) = "N" & z
        z = z + 1
        ActiveCell.Offset(1, 0).Select
        ActiveCell.FormulaR1C1 = "= rc[" & -number_of_sample2 & "]-r2c[" & -number_of_sample2 & "]"
        ActiveCell.Offset(0, 1).Select
        ActiveCell.FormulaR1C1 = "= rc[" & -number_of_sample2 & "]"
        Range(Selection, Selection.Offset(0, -1)).Copy
        ActiveCell.Offset(0, -number_of_sample2 - 1).Select
        Selection.End(xlDown).Select
        ActiveCell.Offset(0, number_of_sample2).Select
        Range(Selection, Selection.End(xlUp)).Select
        ActiveSheet.Paste
        ActiveCell.Offset(-1, 2).Select
    Next i
    hh = 16 + number_of_sample - 1
    ee = 18 + number_of_sample2 * 2
    CR = Range("R1").CurrentRegion.Address
    Range(CR).Calculate
    For j = 1 To number_of_sample
        dd = Application.Round(Cells(hh, 15), 6)
        cc = Columns(ee + 1).Find(What:=dd, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns).Row
        Cells(hh, 16) = Cells(cc, ee).Value
        ee = ee + 2
        hh = hh + 1
    Next j
    'Application.calculation = xlCalculationManual
End Sub

回答
投稿日時: 19/05/17 17:24:36
投稿者: WinArrow
投稿者のウェブサイトに移動

下記のコードをに異本後で説明できますか?
特に「FIND」を含む「For〜Next」を具体的に
他人には、ほとんど理解できません。
 

引用:

    number_of_sample = Range("C8").Value
    Range("c1").Select
    For original_chart_data = 1 To number_of_sample
        For number_of_find = 1 To original_chart_data
            Cells.Find(What:="ストローク/stress", after:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , MatchByte:=False, SearchFormat:=False).Activate
        Next number_of_find
        ActiveCell.Offset(2, 1).Select
        CR = Range(Selection, Selection.Offset(0, -1).End(xlDown)).Address
        Range(CR).Copy
        Cells(2, paste_cell).PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
        :=False, Transpose:=False

回答
投稿日時: 19/05/18 12:22:15
投稿者: simple

こんにちは。
 
WinArrowさんの質問された箇所ですが、
なぜ二重ループにする必要があるのか不思議ですが、
それはこんなことでしょう。
 
Findの起点を after:=ActiveCellとされているが、
貼付の際にActiveCellが動いてしまうから、
それを避けてその都度回数分検索しているわけですね。
 
検索でマッチしたセルを変数で持っておけば、つまり
 Set found = Cells.find(What:="ストローク/stress", after:=found, _以下略
としておけば、単純な一重のループで書けるはずです。
(もちろんfoundをC1セルに初期化しておきます)
 
こうしたこともあるけれど、作業の意図の説明を端折っておいて、
答えだけ求めようとしているのが理解ができない。
 
機械的にコードを書き換えるだけではなく、
もっと適切な標準的なアプローチがあるのではないかという気がする。
中身の処理の検討もせずに、機械的にコードを書き換えるなどということは、
こうしたところで回答している人が、もっとも忌避することじゃないかと思います。
 
# ちなみに、Application.Calculationのテスト(影響調査)の話は伝わっていないようなので、
# 消してもらって結構です。順序も違うので。
# 計算しなくて正解が出ると言うことではなく、影響がどの程度かという話だったので。

回答
投稿日時: 19/05/18 14:50:30
投稿者: WinArrow
投稿者のウェブサイトに移動

>calculateの範囲指定やselectionの減少などコード修正いたしました。
と書かれていますが、
  
calculateは、どこにも記述されていない・・・・
と思って、よく見ると、1ヶ所だけ、セル範囲指定があった。
 
でも、このセル範囲指定はmどうなんでしょう?
セル範囲の指定方法に統一性がない。
表のレイアウトが説明されていないおで、判断できない。
しかし、この方法でよいのなら、他の場所でもこの方法が使えるはず。
無駄?なループもなくなると思う。

回答
投稿日時: 19/05/18 16:07:56
投稿者: WinArrow
投稿者のウェブサイトに移動

日本語の説明をお願いしているコードの中の
FINDメソッドですが、
構文をHELPで確認してみてください。
 
Cells.Find
の「Cells」は、シート全体のセルが検索範囲となります。
要するに、関係のないセル範囲も検索されてしまうということを意味します。
掲示されたコードから、列Cが検索対象であるならば、
Columns("C").Find
と記述すれば、列Cが検索対象となります。
でも、検索するセル範囲が想定できるのであれば
Range("C1:C" & nnn).Find
と記述すれば、もっと範囲を狭めることができます。
 
それから
セルC1から下へ検索している感じを受けますが、
After引数を検索対象のセル範囲の最終セルに設定して
SearchDirection引数を下からを指定すれば、ループせずに
1回で目的のセルが検索できます。
 
 
何度も言いますが、表のレイアウトが説明されていないので、
まったくの当て推量で書いています。
 
要は、目的に併せて、引数をはじめ、コードの一つ一つを吟味して指定することをお勧めします。
 

回答
投稿日時: 19/05/19 14:50:46
投稿者: simple

(1)
各サンプルにおけるデータ数(行数)は異なっているのですね?
 
(2)
Sample数がふたつだとして、
そしてデータの数がそれぞれ3,4という簡単なケースで、
インプットとアウトプットを示して貰えませんか?
 
(3)
   For n = 1 To number_of_sample * 2
        If Cells(2, paste_cell).Value <> "" Then
            Cells(1, paste_cell) = "N" & n
            paste_cell = paste_cell + 1
        End If
    Next n
の所ですが、
Cells(2, paste_cell).Value = "" の箇所があった場合は、
            paste_cell = paste_cell + 1
は実行されませんから、同じ所を判定し続けます。
これで良いのですか?
 
(4)終わりのほうの処理ですが、
dd = Application.Round(Cells(hh, 15), 6)
cc = Columns(ee + 1).Find(What:=dd, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns).Row
ddという小数点以下がある数値を検索しています。
ヒットしないこともありそうですが、上記はエラーになることは想定しないのですか?
かなり稠密な数値データなんでしょうか。
そもそも、ここでやろうとしていることが見えないですね。
 
そのほかいくつか不明点があるのですが、
独り相撲になりそうな気配なので、列挙はここまでとしておきます。

回答
投稿日時: 19/05/26 10:28:17
投稿者: simple

もう興味を失ってしまっているんでしょうか?
 
Select,ActiveCellなどを使わずに、
できるだけ意図が明確がわかるように書いてみました。
 
ところどころに十分に理解できないところがありましたが、
せっかく書いたので、upしておきます。
 

Sub chart_data_collecting()
    Dim colStart    As Long
    Dim nSamples    As Long
    Dim found       As Range
    Dim dSize()     As Long
    Dim curRegion   As Range
    Dim rTable      As Long
    Dim r           As Range
    Dim v           As Double
    Dim threshold   As Double
    Dim k           As Long
    Dim s           As String
    
    Application.Calculation = xlCalculationManual   '暫定的に手動計算
    
    nSamples = Range("C8").Value    'サンプル数
    ReDim dSize(1 To nSamples)      '各サンプルのデータサイズ
    
    colStart = 18           '作成するグラフ表の開始列
    
    '(1) グラフ表1の見出し ------------------
    For k = 1 To nSamples * 2
         Cells(1, colStart + (k - 1)).Value = "N" & k
    Next
    
    '(2) グラフ表1 への転記
    Set found = Range("C1")
    For k = 1 To nSamples
        Set found = Columns("C").find(What:="ストローク/stress", after:=found, _
             LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
             SearchDirection:=xlNext, MatchCase:=False, _
             MatchByte:=False, SearchFormat:=False)
        Set found = found.Offset(2)          'キーワードの2行下からデータが開始
        dSize(k) = Range(found, found.End(xlDown)).Rows.Count 'データの大きさ
        found.Resize(dSize(k), 2).Copy
        Cells(2, colStart + 2 * (k - 1)).PasteSpecial Paste:=xlPasteValues
    Next
    
    '(3) グラフ表2 ----------------------------------------------
    colStart = 18 + nSamples * 2
    
    ' 見出し(グラフ表1の見出しを流用)
    Range("R1").Resize(1, nSamples * 2).Copy
    Cells(1, colStart).PasteSpecial Paste:=xlPasteValues
    
    threshold = Worksheets("main").Range("G14").Value   '閾値
    For k = 1 To nSamples
        Cells(2, colStart + 2 * (k - 1)).Resize(dSize(k), 1).FormulaR1C1 _
            = "=IF(RC[" & -nSamples * 2 + 1 & "]>" & threshold _
            & ",RC[" & -nSamples * 2 & "],"""")"
        Cells(2, colStart + 2 * (k - 1) + 1).Resize(dSize(k), 1).FormulaR1C1 _
            = "=IF(RC[" & -nSamples * 2 & "]>" & threshold _
            & ",RC[" & -nSamples * 2 & "],"""")"
       '値に置換
        Cells(2, colStart + 2 * (k - 1)).Resize(dSize(k), 2).Value _
            = Cells(2, colStart + 2 * (k - 1)).Resize(dSize(k), 2).Value
    Next
    
    '(4) グラフ表2のデータ中のタブ展開?(意味不明。次の列を壊さないのか?)
    For k = 1 To nSamples * 2
        Columns(colStart + k - 1).TextToColumns _
            Destination:=Cells(1, colStart + k - 1), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=False, _
            FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
    Next
    
    '(5) グラフ表1,2に空白セルがあれば上に詰める(必要?行の整合性が壊れない?)
    Set curRegion = Range("R1").CurrentRegion
    If WorksheetFunction.CountBlank(curRegion) <> 0 Then
        curRegion.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
    End If
    
    '(6) グラフ表3 -------------------------------------------------
    colStart = 18 + nSamples * 4
    
    '見出し(前と同じ)
    Range("R1").Resize(1, nSamples * 2).Copy
    Cells(1, colStart).PasteSpecial Paste:=xlPasteValues
    
    For k = 1 To nSamples
        Cells(2, colStart + 2 * (k - 1)).Resize(dSize(k), 1).FormulaR1C1 _
            = "= rc[" & -nSamples * 2 & "]-r2c[" & -nSamples * 2 & "]"
        Cells(2, colStart + 2 * (k - 1) + 1).Resize(dSize(k), 1).FormulaR1C1 _
             = "= rc[" & -nSamples * 2 & "]"
       '値に置換
        Cells(2, colStart + 2 * (k - 1)).Resize(dSize(k), 2).Value _
            = Cells(2, colStart + 2 * (k - 1)).Resize(dSize(k), 2).Value
    Next
    
    'Range("R1").CurrentRegion.Calculate ' 必要なのか?
    
    '(7) ---- 表4 ---------------------- 全般に意図が不明でした
    colStart = 18 + nSamples * 4    '表3の開始列と同じ
    rTable = 16 + nSamples - 1      '表4の開始行
    For k = 1 To nSamples
        v = Application.Round(Cells(rTable + k - 1, 15).Value, 6)
        Set r = Columns(colStart + 2 * (k - 1) + 1).find(What:=v, _
                LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns)
        ' 小数点付き数値が必ず見つかる保証があるのか?
        If Not r Is Nothing Then ' エラー回避のため、マッチしたときだけ転記
            Cells(rTable + (k - 1), 16).Value = Cells(r.Row, colStart + 2 * (k - 1)).Value
        End If
    Next
    
    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic    '自動計算に戻す
End Sub

トピックに返信