配列から直接、指定範囲の文字列を取得。

投稿者 : ハム     投稿日時 : 2024/10/08(Tue) 13:45:19     OS : Windows 10     EXCEL : 未指定

---

ハムと申します。
すみません。お助け下さい。
Application.Indexでの文字列取得に対し、行の範囲指定を行いたく。


下記コードの①summaryWs.Cells(summaryLastRow, colIndex).Resize(endRow - startRow + 1, 1).Value = Application.Index(dataArray, Evaluate("ROW(" & startRow & ":" & endRow & ")"), j)で、
実行時エラー(1004 アプリケーション定義またはオブジェクト定義のエラーです)が発生し、修正できません。

.Indexで取得する配列の範囲の、行の範囲をEvaluateで指定したいのですが、ws.Evaluate～や、dataArray.Evaluate～と、対象シートを指定してもエラーを消せません。(Evaluateはアクティブシートを対象とするため)。

ご助言頂きたく、よろしくお願いいたします。

Sub データ集約()
    Dim folderPath As String
    Dim fileName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim summaryWs As Worksheet
    Dim dataArray As Variant
    Dim i As Long
    Dim j As Long
    Dim summaryLastRow, summaryLastRow2 As Long
    Dim keywords As Variant
    Dim keyword As Variant
    Dim found As Boolean
    Dim startRow As Long
    Dim endRow As Long
    Dim colIndex, colIndex2 As Long
    Dim kanri, motokanri As String
    Dim key As Variant
    Dim OutArray() As Variant
    Dim siyoRow As Long

    MsgBox "マスタのエクセルを選択してください"
    motokanri = Application.GetOpenFilename("Excel,*.xls?")

    If motokanri <> "False" Then
        Set motokanribook = Workbooks.Open(motokanri)
        DoEvents
    End If

    Set summaryWs = motokanribook.Worksheets("管理表")


    MsgBox "回答ファイルの、保存フォルダを選択してください"

    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

    ' 検索キーワードの配列を設定
    keywords = Array("項目名", "システム名")

    ' フォルダ内のすべてのExcelファイルをループ
    fileName = Dir(folderPath & "\*.xls?")
    Do While fileName <> ""
        ' 各ファイルを開く
        Set wb = Workbooks.Open(folderPath & "\" & fileName)

        ' 各シートをループ
For Each ws In wb.Sheets
            ' シート名の頭3文字が「仕様」の場合のみ処理
            If Left(ws.name, 3) = "仕様" Then
                ' シートの全データを配列に格納
                dataArray = ws.UsedRange

                ' A列に「仕様」と書かれている行を見つける
                siyoRow = 0
                
                For i = 1 To UBound(dataArray, 1)
                    If dataArray(i, 1) = "仕様" Then
                        siyoRow = i
                        Exit For
                    End If
                Next i

                ' 「仕様」が見つかった場合のみ処理を続行
                If siyoRow > 0 Then
                    ' 配列内で各キーワードを検索
                    For Each keyword In keywords
                    
                        found = False
                        
                        For j = 1 To UBound(dataArray, 2)
                            If dataArray(siyoRow, j) = keyword Then
                                found = True
                                Exit For
                            End If
                        Next j

                        ' キーワードが見つかった場合の、まとめシートへの書き込み先の指定
                        If found = True Then
                        
                            startRow = siyoRow + 1
                            endRow = ws.Cells(ws.Rows.count, j).End(xlUp).Row

                            ' 転記先の列を指定
                            Select Case keyword
                                Case "項目名"
                                    colIndex = 4 ' D列
                                Case "システム名"
                                    colIndex = 5

                            End Select

                            ' まとめシートの転記先の列の最終行を取得
                            summaryLastRow = summaryWs.Cells(summaryWs.Rows.count, colIndex).End(xlUp).Row + 1

                            ' まとめシートに出力
　　　　　　　　　　　　　　　①summaryWs.Cells(summaryLastRow, colIndex).Resize(endRow - startRow + 1, 1).Value = Application.Index(dataArray, Evaluate("ROW(" & startRow & ":" & endRow & ")"), j)
     
                        End If
                        
                    Next keyword
                    


                End If
                
            End If
            
Next ws

        ' ファイルを閉じる
        wb.Close SaveChanges:=False

        ' 次のファイルへ
        fileName = Dir
    Loop


End Sub

投稿者 : tkit     投稿日時 : 2024/10/08(Tue) 16:27:51

---

本当にEvaluate関数が原因で、エラーが出ているのですか？
他のCellsやResizeの引数が0やマイナスになっていませんか？

投稿者 : ハム     投稿日時 : 2024/10/08(Tue) 16:37:19

---

■[返信 1] tkitさん（2024-10-08 16:27:51）の記事
＞ 本当にEvaluate関数が原因で、エラーが出ているのですか？
＞ 他のCellsやResizeの引数が0やマイナスになっていませんか？


tkit様
ご返信いただき、ありがとうございます。

他のCellsやResizeの引数は0やマイナスになっておらず、
狙い通りの行数／列数であることを、確認しております。

.Indexを用いての、Evaluateの行範囲指定は可能であるかご存じでしょうか。
また、他に懸念点ございましたら、お教えください。

投稿者 : tkit     投稿日時 : 2024/10/08(Tue) 17:01:33

---

やってみたら出来ました。

Sub Sample()
    Dim n&, temp, v, s&, e&, rng As Range
    s = 1: e = 10
    temp = Selection.Value 'A1:C10選択
    v = Application.Index(temp, Evaluate("ROW(" & s & ":" & e & ")"), 2)
    Set rng = Range("E1").Resize(e - s + 1, 1): Debug.Print rng.Address
    rng.Value = v
End Sub

貼り付け範囲やApplication.Indexの返り値が正しいか、
上記のように確認してください。

投稿者 : ごんぼほり     投稿日時 : 2024/10/08(Tue) 17:04:47

---

このコードは、暗にUsedRnageが１行目から開始していることを前提にしています

endRow = ws.Cells(ws.Rows.count, j).End(xlUp).Row
としていますが
UsedRangeが1行目から開始していない場合、
EndRow > UBound(dataArray,1)
となる可能性があり、このとき
Application.Index(dataArray, Evaluate("ROW(" & startRow & ":" & endRow & ")"), j)
がエラーになるのではないかと推量します。

投稿者 : ごんぼほり     投稿日時 : 2024/10/08(Tue) 17:19:15

---

ちがいました。
上記の場合#Refになるだけで、実行時エラーにはならないようです。

投稿者 : tek     投稿日時 : 2024/10/08(Tue) 17:54:16

---

情報ありがとうございます。
なにこれ、すごすぎる！！
VBAで部分配列が1ステートメントでできるんだ。

Sub Sample1()
    With Range("a1:c10")
        .Value = [address(row(1:10),column(1:4),4)]
        temp = .Value
    End With
    v = Application.Index(temp, Evaluate("row(3：5)"), Evaluate("column(b:c)"))
    With Range("F1")
        .ClearContents
        .Resize(UBound(v), UBound(v, 2)).Value = v
    End With
End Sub

投稿者 : tek     投稿日時 : 2024/10/09(Wed) 08:05:26

---

直しませんが、昨日はすぐ出かければならなかったので中途半端なコードで申し訳ありませんでした。
.Indexを用いての、Evaluateの行範囲指定は可能である→行列範囲指定も可能ということに感動しました。

＞59 ' A列に「仕様」と書かれている行を見つける
ご提示のコードですとごんぼほりさんもご指摘のようにws.UsedRangeの左上はA1セルで無いと成立しないはずですので、
右辺はws.range(ws.cells(startrow,j),ws.cells(endrow,j)).valueで良いでしょう。


＞また、他に懸念点ございましたら、お教えください。
1列内にデータがあったら2行のデータ有無を調査する為にすべてのデータを配列に入れるのは無駄でしょう。
A列をApplication.Matchで検索し、対象行をApplication.Matchで2回検索すれば良いと思います。
その場合、keywordの有る列をfound(型：Variant/Double)とした場合、
右辺は、ws.Range(ws.Cells(startRow, found), ws.Cells(endRow, found)).Valueとなります。

＞16 Dim colIndex, colIndex2 As Long
　ではcolIndex As Variant　と定義されていることを認識ください。

＞54 ' シート名の頭3文字が「仕様」の場合のみ処理
"仕様"の文字数は2です。

＞25 If motokanri <> "False" Then
＞26 Set motokanribook = Workbooks.Open(motokanri)
＞27 DoEvents
不要です（何のために入れていますか？）
else
exit sub　が必要です。motokanri = "False"の場合30でエラーになります。
＞28 End If

＞120 fileName = Dir
Dirを右辺にした場合　Office VBA リファレンスに
フォルダー内のすべてのファイルに対して反復処理を行うには、空の文字列を指定します。
VB
Dir()
とあるよう、
fileName = Dir()
としたほうが私は好きです。

＞36 If .Show = -1 Then
If .Show Then
とすべきです。 わざわざ If True = True Then とは書きませんよね？

＞117 wb.Close SaveChanges:=False
他の関数の使い方（引数の書き方）に合わせ (MsgBox prompt:="マスタのエクセルを選択してください"とは書いていませんよね)私なら、
wb.Close False
と書きます。

投稿者 : tkit     投稿日時 : 2024/10/09(Wed) 09:27:51

---

■[返信 2] ハムさん（2024-10-08 16:37:19）の記事
＞ .Indexを用いての、Evaluateの行範囲指定は可能であるかご存じでしょうか。

生真面目ですが、
公式ではIndex関数の行指定である第2引数の型はDoubleとなっています。
https://learn.microsoft.com/ja-jp/office/vba/api/excel.worksheetfunction.index

提示の使い方は、裏技的なものとなり、今後のバージョンアップ等で、
使えなくなる可能性があります。


ただ、公式通りの使い方で、配列の抜き取りを１行で書けるのは利点ですね。
コストはループさせ代入するより10倍でしたが。

Sub sample2()
    Dim arr
    arr = ThisWorkbook.Worksheets(1).Range("A1:D20").Value
    Dim arr2(2, 1), i&, j&
    For i = LBound(arr2, 1) To UBound(arr2, 1)
        For j = LBound(arr2, 2) To UBound(arr2, 2)
            arr2(i, j) = CStr(i) & "_" & CStr(j)
        Next
    Next
    Dim temp
    temp = Application.Index(arr, 0, 2)  '指定の行全体または列全体を取得出来る
    temp = Application.Index(arr2, 0, 2) '指定は行番号または列番号で、配列のインデックスでは無い
    temp = Application.Index(arr2, 0, 0) '行全体、列全体で取得すると、インデックス1から始まる配列で取得出来る
End Sub

Sub sample3()
    '実行時間取得
    Dim arr
    arr = ThisWorkbook.Worksheets(1).Range("A1:D20").Value
    Dim temp, i&, j&, t#
    t = Timer
    For i = 1 To 100000
        temp = Application.Index(arr, 0, 2)
    Next
    Debug.Print Timer - t
    
    t = Timer
    ReDim temp(1 To 20, 1 To 1)
    For i = 1 To 100000
        For j = 1 To 20
            temp(j, 1) = arr(j, 2)
        Next
    Next
    Debug.Print Timer - t
    
End Sub

投稿者 : ハム     投稿日時 : 2024/10/09(Wed) 13:45:42

---

tkit様、ごんぼほり様、tek様

ハムでございます。

ご多忙の中、様々なアドバイス／知見頂きまして、
誠にありがとうございます。

まさかこれ程、ご丁寧にご助言頂けるとは思っておりませんで、
大変勉強になります。

ハムは、VBAを全くわかっておりませんで、
今後ともこの掲示板にてご指導頂けますと、大変有難く、
是非とも宜しくお願い申し上げます。

失礼致します。

※endRow - startRow + 1 = 0にあるデータ(記載必須の情報が、不具合で未記載)
　の存在が、今回のエラーの原因でした。