VBA マクロを使った指定の文字列の抽出方法

Question

以下のマクロを実行すると以下の「転記先」のように転記が実行されます。
現在のソースでは、転記元の「開発A」、「開発B」というのは以下の「該当箇所」で抽出しているのですが、
それだと、「転記元」のB29,B30、B39、B40のようなセルが同じ列に含まれているときに、そちらも抽出してしまい、予期せぬ動きをしてしまいます。

今回だと、B14,B32の「開発A」、「開発B」のセルの内容のみをピンポイントで検索して、抽出する方法があれば教えていただきたいです。
「開発A」、「開発B」というのは担当者の数が可変なので、行が変わる可能性があり、そのセルの内容を例えばCell(14,3)のように一定の場所で指定することはできません。

該当箇所

'①
If Left(.Cells(i, 2).Value, 2) = "開発" Then

転記先

転記元

現状のソース

Sub sample1()

    Dim lngRowsNo       As Long                     ' 書きこむ位置
    Dim lngSheetIndex   As Long                     ' シートの番号
    Dim strFile         As String                   ' Excelファイルの場所
    Dim xlsAcq          As New Excel.Application    ' 取得側Excel
    Dim wbAcq           As Workbook                 ' 取得側Excelブック
    Dim wsAcq           As Worksheet                ' 取得側Excelシート
    Dim wsSet           As Worksheet                ' 設定側Excelシート
    Const strPath       As String = "パスを指定する"
    Set wsSet = ActiveSheet
    Dim i As Long

     strFile = Dir(strPath & "*.xls")
    lngRowsNo = 3
    Do Until strFile = ""
        '----- Excelブックを開く
        Set wbAcq = Workbooks.Open(strPath & strFile)

        '----- シートを検索
        For lngSheetIndex = 1 To wbAcq.Worksheets.Count
            '----- 「更新」シートを検索
            If wbAcq.Worksheets(lngSheetIndex).Name = "更新" Then
                '----- 「更新」シートを変数へ登録
                Set wsAcq = wbAcq.Worksheets(lngSheetIndex)
                '----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
                With wsAcq
                Dim fname As String        'ファイル名
                Dim n As Long                  'ループで使用します。
                Dim m As Long                  'ループで使用します。
                Dim ec1 As Long               '各開発の一番下の担当者のセルを取得
                Dim ec2 As Long               '各開発の 月の一番右（最後）のセルを取得
                Dim ColumnNo As Long    ' 転記先の列番号（初期値４）
                Dim ColumnNo2 As Long    ' 転記元の列番号（初期値５）＋３されていく
                
                ColumnNo = 4
                ColumnNo2 = 5

                For i = 1 To .UsedRange.Rows.Count
　　　　　　　　　　　　'①
                    If Left(.Cells(i, 2).Value, 2) = "開発" Then
                     '月を取得して転記
                    ec2 = .Cells(i + 1, 5).End(xlToRight).Column + 1
                    For col = 5 To ec2
                    
                        wsSet.Cells(2, ColumnNo).Value = .Cells(i + 1, ColumnNo2).Value
                        
                        ColumnNo = ColumnNo + 1
                        ColumnNo2 = ColumnNo2 + 3
                        
                    Next col

                    ' ------ 開発〇から一番上の担当者のセル位置を相対的にCells(i + 3, 3)として取得し
                     'データの入っているところまでループさせる (その時、開発名を転記)
                     ec1 = .Cells(i + 3, 2).End(xlDown).Row
                        For n = i + 3 To ec1
                        
                        '担当者が空白の時スキップする
                        If Cells(n, 3) = "" Then
                        GoTo NEXT99
                        End If
                        
                            'ファイル名
                            fname = ActiveWorkbook.Name
                            wsSet.Cells(lngRowsNo, 1).Value = fname
                            
                            '開発
                            wsSet.Cells(lngRowsNo, 2).Value = .Cells(i, 2).Value
                            
                             '担当者
                            wsSet.Cells(lngRowsNo, 3).Value = .Cells(n, 3).Value
                            
                             '工数
                            wsSet.Cells(lngRowsNo, 4).Value = .Cells(n, 5).Value
                            
                            wsSet.Cells(lngRowsNo, 5).Value = .Cells(n, 8).Value
                            
                            wsSet.Cells(lngRowsNo, 6).Value = .Cells(n, 11).Value
                            
                            wsSet.Cells(lngRowsNo, 7).Value = .Cells(n, 14).Value
                            
                            wsSet.Cells(lngRowsNo, 8).Value = .Cells(n, 17).Value
                            
                            wsSet.Cells(lngRowsNo, 9).Value = .Cells(n, 20).Value
                            
                            wsSet.Cells(lngRowsNo, 10).Value = .Cells(n, 23).Value
                            
                            wsSet.Cells(lngRowsNo, 11).Value = .Cells(n, 26).Value
                            
                            wsSet.Cells(lngRowsNo, 12).Value = .Cells(n, 29).Value
                            
                            wsSet.Cells(lngRowsNo, 13).Value = .Cells(n, 32).Value
                            
                             '１行下へ
                            lngRowsNo = lngRowsNo + 1
                            
NEXT99:
                        Next n
                    End If
                Next i
                End With
               
                '----- 検索の終了
                Exit For
            End If
        Next lngSheetIndex

        '----- シート参照の解放
        Set wsAcq = Nothing
        '----- ブックを閉じる
        wbAcq.Close Savechanges:=False
        '----- 次のファイルへ
        strFile = Dir()
    Loop

    '----- Excelへの参照の解放
    Set xlsAcq = Nothing

End Sub

Answer 1

転記元のシート画像を見ると「No」の上のセルを参照すればいいはずなので、
Find/FindNextメソッドで「No」を完全一致で検索して見つかったセルの一つ上を参照するようにすればいいかと。
（その方が高速なはず。）

条件に当てはまるセルを検索する(Find/FindNext/FindPreviousメソッド) ：Excel VBA｜即効テクニック｜Excel VBAを学ぶならmoug

あるいは、Match関数で検索してもいいでしょう。（こちらの方かさらに高速。）

【ExcelVBA入門】MATCH関数を使ったセル範囲を検索する方法を徹底解説！ | 侍エンジニア塾ブログ（Samurai Blog） - プログラミング入門者向けサイト

---

+を付けてくれた人のために、
MATCH関数を使った場合のコード例

Public Sub sample1()
'前略
    With wsAcq
        Dim LastRow As Long
        LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
        Dim TargetRow As Long
        TargetRow = 1
        
        Dim MatchRow As Long
        MatchRow = 1
        
        Do
            With Application
                MatchRow = .IfError(.Match("No", .Range("B" & TargetRow & ":B" & LastRow), 0), 0)
            End With
            TargetRow = TargetRow + MatchRow - 2
            If MatchRow <> 0 Then
                Dim 開発 As String
                開発 = .Cells(TargetRow, 2).Value
                
                '転記処理省略


            End If
            TargetRow = TargetRow + 3
        Loop Until MatchRow = 0

    End With

'後略
End Sub

Answer 2

対策は２つあります。

１案　
最初の２文字が"開発"かどうかで判断しているので、
「開発A質問」　ではなく　「☆開発A質問」　のように頭に適当な1文字を追加して、最初の２文字が開発
にならないようにする。これだと、ソースの変更は不要です。

２案
「開発A質問」の文字があるのが、結合セルであることに注目して
最初の２文字が開発かつそのセルが結合セルでないなら処理をおこなうようにする。
具体的には
If Left(.Cells(i, 2).Value, 2) = "開発" Then　を
If Left(.Cells(i, 2).Value, 2) = "開発" And .Cells(i, 2).MergeCells = False Then
に変更する。
但し、この方法は、今後、開発A、開発Bのセルを結合セルにしないことが条件となります。

Comments

[icecleam]

ありがとうございます。
上記の第2案で無事にやりたいことを実行できました！

余談なのですが、例えば今回「開発A」、「開発B」のように「開発」という共通の文字列で検索をかけましたが、これが「マクロ」、「ジャバ」であった時のように全く違う文字列であった時の検索方法は以下のようになるのでしょうか。
ちょっと以下のコードで試しに動かして見たのですが、うまく動いてくれなかったので。。
If Left(.Cells(i, 2).Value, 3) = "マクロ " And Left(.Cells(i, 2).Value, 3) = "ジャバ" And .Cells(i, 2).MergeCells = False Then

[tatsu99]

If (Left(.Cells(i, 2).Value, 3) = "マクロ " Or Left(.Cells(i, 2).Value, 3) = "ジャバ") And .Cells(i, 2).MergeCells = False Then
にしてください。
あなたの書いたマクロは、日本語では
そのセルが「マクロ」かつ「ジャバ」であり、かつそのセルが結合セルでないなら
になります。１つのセルの内容が「マクロ」と「ジャバ」の両方の値をとることはあり得ません。よってその式が成立することは、絶対にありません。
正しい日本語では、
そのセルが「マクロ」又は「ジャバ」であり、かつそのセルが結合セルでないこと
になります。マクロで記述した場合は、OrよりもAndの方が強いので、
(Left(.Cells(i, 2).Value, 3) = "マクロ " Or Left(.Cells(i, 2).Value, 3) = "ジャバ")
のようにOrの部分をカッコでくくり、こちらを優先させます。

[icecleam]

ありがとうございます！
とても勉強になりました。

日本語に直してみたら確かに一目瞭然ですね。
ご対応いただきありがとうございました！