VBA マクロを使った条件付きのエクセルファイル同士の転記方法

Question

■マクロの概要
以下の画像のようにブックからブックへ転記をしたいです。
その時、転記元のエクセルファイル（拡張子はxls）が格納されているフォルダを指定してそのフォルダ内のエクセルファイルすべてに対してに「更新」というシートがあるときだけ以下の画像のように転記を実行したいです。

転記元

転記先

以下の箇所で、転記を実装します。
以下のソースでは実行するとB1に「開発A」、B2に「開発B」と転記されます。
これを担当者の数だけ「開発A」で繰り返し、その後に「開発B」という画像の転記先のように繰り返して転記していきたいのですが、うまくできません。
●転記する

                '----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
                With wsAcq
                For i = 1 To .UsedRange.Rows.Count
                    If Left(.Cells(i, 2).Value, 2) = "開発" Then
                    wsSet.Cells(lngRowsNo, 2).Value = .Cells(i, 2).Value
                    lngRowsNo = lngRowsNo + 1
                    End If
                Next i
                End With
                '----- 書きこむ位置移動
               
                '----- 検索の終了

●現在のソース

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

     strFile = Dir(strPath & "*.xls")
    lngRowsNo = 1
    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 = Worksheets(lngSheetIndex)
                '----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
                wsSet.Cells(lngRowsNo, 1) = wsAcq.Cells(1, 1)
                '----- 書きこむ位置移動
                lngRowsNo = lngRowsNo + 1
                '----- 検索の終了
                Exit For
            End If
        Next lngSheetIndex

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

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

End Sub

Comments

[meg_]

気になったのは「Set wsAcq = Worksheets(lngSheetIndex)」です。

Set wsAcq = wbAcq.Worksheets(lngSheetIndex)　が正しいのではないでしょうか？

[icecleam]

以下のように修正し、実行しましたが相変わらずxlsファイルを開閉して何も転記されませんでした。。

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

strFile = Dir(strPath & "*.xls")
lngRowsNo = 1
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)
'----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
wsSet.Cells(lngRowsNo, 1) = wsAcq.Cells(1, 1)
'----- 書きこむ位置移動
lngRowsNo = lngRowsNo + 1
'----- 検索の終了
Exit For
End If
Next lngSheetIndex

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

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

End Sub

[meg_]

確認ですが「wsAcq.Cells(1, 1)」に値は入力されていますか？
「wsSet.Cells(lngRowsNo, 1) = wsAcq.Cells(1, 1)」の後に「debug.Print wsSet.Cells(lngRowsNo, 1).Value」「debug.Print wsAcq.Cells(1, 1).Value」の結果はどうなりますか？

[icecleam]

上記のソースにパスを入力してあげたものを実行しただけでした。。
値の入力というのは、今回の画像のような実装の場合、どのようにすれば良いのでしょうか。。

以下のように記載しました。
結果というのはどのようにして確認すれば良いでしょうか。。

すみません、 初心者なもので両者とも初歩的な質問かもしれません。。
'----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
wsSet.Cells(lngRowsNo, 1) = wsAcq.Cells(1, 1)
Debug.Print wsSet.Cells(lngRowsNo, 1).Value
Debug.Print wsAcq.Cells(1, 1).Value

[meg_]

VBEのイミディエイトウィンドウにDebug.Printの結果が出力されてませんか？

[icecleam]

イミディエイトウィンドウを開きながら実行したのですが、何も表示されませんでした。
これはやっぱり、そもそも値を取れてないんですかね。。

[meg_]

Cells(1, 1)はセルA1のことです。質問の画像では見えませんが、何か値は入力されているんですか？空白セルではありませんか？

[icecleam]

そうですね、実行すると空白のセルになります。
すみません、この場合の値の入力というのは、どのようにすれば良いのでしょうか。

[icecleam]

初歩的な質問ばかりで申し訳ないです。

[meg_]

転記元のデータを転記先にコピーしたいのですよね？
例えば「開発A」とか「開発B」をコピーしたいのであれば、転記元のB列から「開発」が先頭にある文字列を捜して取得する、などの処理が必要になるかと思います。

[icecleam]

そうです。
まずはファイル名と開発をコピーしたいです。
その場合、転記先のファイルのA1に「ファイル名」、B1に「開発」と記載し、それに該当する列の2以降から、転記元の内容をコピーする
ということでしょうか

一晩考えたのですが、列から「〇〇」が先頭にある文字列を捜して取得する
処理の実装が、何度やっても空白セルとなり、うまくできませんでした…
申し訳ありませんが、この場合の具体的な書き方まで教えていただけないでしょうか。
ひとつ分かれば、後もそれを参考にして実装できそうですので…

[meg_]

例えば下記のように書けます。

Dim i As Long

With wsAcq
For i=1 to .UsedRange.Rows.Count
If Left(.Cells(i,1).Value,2)="開発" Then
'処理を書く
End If
Next i

[icecleam]

ありがとうございます。
いま手元に端末がないので、試してはいないのですが、これを
wsSet.Cells(lngRowsNo, 1) = wsAcq.Cells(1, 1)
と置き換えれば、開発1.開発2の値を転記できるということでしょうか

[meg_]

> 開発1.開発2の値を転記
開発A、開発Bではなくてですか？

> wsAcq.Cells(1, 1)
これですとセル番地を固定してるので同じ値をコピーすることしかできません。

何かVBAをあまり理解されていないようですが、質問のコードはご自身で書かれたものでしょうか？

[radames1000]

https://teratail.com/questions/292072#reply-413294

[icecleam]

> 開発A、開発Bではなくてですか？
すみません、ただの誤字でした。

wsSet.Cells(lngRowsNo, 1) = wsAcq.Cells(1, 1)
の部分をmeg_さんが先ほど記載していただいた内容に置き換えるという意味でした。
すみません、伝わりづらかったですね。

このコードは、以前質問をさせていただいて、その回答としていただいたものです。
すみません、理解できていない部分は正直あります…

[meg_]

コードを修正して動かしてみてください。エラーが出たり、意図通りに動かなったらデバッグしてください。何度も繰り返してプログラムは完成するものだと思います。

[meg_]

>If Left(.Cells(i, 1).Value, 2) = "開発" Then
B列なので
If Left(.Cells(i, 2).Value, 2) = "開発" Then
ですね。
今朝の私のコメントから間違ってましたね。

[icecleam]

ありがとうございます。
今、それで実行してみたらB2に開発Aと転記することができました。
コードは以下になります
'----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)

With wsAcq
For i = 1 To .UsedRange.Rows.Count
If Left(.Cells(i, 2).Value, 2) = "開発" Then

wsSet.Cells(lngRowsNo, 2) = wsAcq.Cells(14, "B")

End If
Next i
End With

[icecleam]

今はピンポイントでB14の値を取ってきていますが
あとはこれを担当者の数だけループで回したいです、、

質問内容も編集しましたので、ご迷惑でなければご回答をいただければと思います。。
長時間付き合わせてしまい申し訳ないです

[meg_]

シート（wsAcq）の行番号が変数 i なので、
If Left(.Cells(i, 2).Value, 2) = "開発" Then
wsSet.Cells(lngRowsNo, 2).Value = .Cells(i, 2).Value
で良いかと。

[icecleam]

上記で試してみたところB2セルに「開発B」が一つだけ記載されるだけでした。。

修正したソースは以下になります。
'----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
With wsAcq
For i = 1 To .UsedRange.Rows.Count
If Left(.Cells(i, 2).Value, 2) = "開発" Then
wsSet.Cells(lngRowsNo, 2).Value = .Cells(i, 2).Value

End If
Next i
End With

[meg_]

> 上記で試してみたところB2セルに「開発B」が一つだけ記載されるだけでした。。
１．B2セルに「開発A」が入力されて、B2セルに「開発B」が入力されているかと思います。ステップ実行で確かめてください。
２．lngRowsNo = lngRowsNo + 1　は入れてますか？

[icecleam]

ステップ実行したら、開発Aの後に開発Bになっていました！

下の方まで記載すると、以下のようになっています。
'----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
With wsAcq
For i = 1 To .UsedRange.Rows.Count
If Left(.Cells(i, 2).Value, 2) = "開発" Then
wsSet.Cells(lngRowsNo, 2).Value = .Cells(i, 2).Value

End If
Next i
End With
'----- 書きこむ位置移動
lngRowsNo = lngRowsNo + 1

[icecleam]

これは繰り返しはできているが、転記しているのが常にB2で固定されているということでしょうか？

[meg_]

lngRowsNoが「2」のままなのでしょう。「開発B」は開発Aの担当者（A～H）の数分下の行に転記する必要があります。

[icecleam]

lngRowsNoのカウントを進めようと思い、以下のようにしたところ、
B1に「開発A」、B2に「開発B」が転記されてしまいました。

「「開発B」は開発Aの担当者（A～H）の数分下の行に転記」
ここの部分で担当者に値が入っている数分、「開発A」を記載するにはどのような処理にすれば良いでしょうか。。

インターネットで調べたら、データのある最後の行位置の変数を以下の式で取れるそうなのですが、今回の場合、転記元の１７行目から２４行目までの担当者（これはファイルによって可変）の実数値でいうと８を取ってきたいです。。
n = Cells(Rows.Count, "C").End(xlUp).Row

'----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
With wsAcq
For i = 1 To .UsedRange.Rows.Count
If Left(.Cells(i, 2).Value, 2) = "開発" Then
wsSet.Cells(lngRowsNo, 2).Value = .Cells(i, 2).Value
lngRowsNo = lngRowsNo + 1
End If
Next i
End With
'----- 書きこむ位置移動

'----- 検索の終了

[meg_]

「開発A」の担当者「A」のセル位置が分かっているとします。(例：Cells(17,2)) ※
「H」のセルは下記コードで取得できます。
.Cells(17,2).End(xlDown)

※最初の担当者のセル位置はプロジェクト名（開発Aとか）からの相対位置で取得可能です

[icecleam]

以下のコードで、開発AをB1〜B8、開発BをB9〜B12に思った通りに転記することができました！
meg_さんのアドバイスのおかげです。
ようやく１つ前進することができました。
この質問は、このコードを回答とし、また行き詰まったら別の質問としてあげさせていただきます。
お付き合い頂き、本当にありがとうございました

'----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
With wsAcq
Dim n As Long 'ループで使用します。
Dim ec1 As Long '各開発の一番下の担当者のセルを取得

For i = 1 To .UsedRange.Rows.Count

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

' ------ 開発〇から一番上の担当者のセル位置を相対的にCells(i + 3, 3)として取得し
'データの入っているところまでループさせる (その時、開発名を転記)

ec1 = .Cells(i + 3, 3).End(xlDown).Row
For n = i + 3 To ec1

wsSet.Cells(lngRowsNo, 2).Value = .Cells(i, 2).Value

lngRowsNo = lngRowsNo + 1

Next n

End If
Next i
End With

Answer 1

以下のように
ソースを修正し、無事に開発者の部分は実装することができました。

'----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
With wsAcq
Dim n As Long 'ループで使用します。
Dim ec1 As Long '各開発の一番下の担当者のセルを取得

For i = 1 To .UsedRange.Rows.Count

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

' ------ 開発〇から一番上の担当者のセル位置を相対的にCells(i + 3, 3)として取得し
'データの入っているところまでループさせる (その時、開発名を転記)

ec1 = .Cells(i + 3, 3).End(xlDown).Row
For n = i + 3 To ec1

wsSet.Cells(lngRowsNo, 2).Value = .Cells(i, 2).Value

lngRowsNo = lngRowsNo + 1

Next n

End If
Next i
End With