質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
87.20%
ファイル

ファイルとは、文字列に基づいた名前又はパスからアクセスすることができる、任意の情報のブロック又は情報を格納するためのリソースです。

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

解決済

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

icecleam
icecleam

総合スコア0

ファイル

ファイルとは、文字列に基づいた名前又はパスからアクセスすることができる、任意の情報のブロック又は情報を格納するためのリソースです。

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

1回答

0評価

0クリップ

656閲覧

投稿2020/09/17 13:19

編集2022/01/12 10:58

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

転記元
転記元

転記先
転記先

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

Macro

'----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい) 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 '----- 書きこむ位置移動 '----- 検索の終了

●現在のソース

Macro

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

良い質問の評価を上げる

以下のような質問は評価を上げましょう

  • 質問内容が明確
  • 自分も答えを知りたい
  • 質問者以外のユーザにも役立つ

評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

気になる質問をクリップする

クリップした質問は、後からいつでもマイページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

  • プログラミングに関係のない質問
  • やってほしいことだけを記載した丸投げの質問
  • 問題・課題が含まれていない質問
  • 意図的に内容が抹消された質問
  • 過去に投稿した質問と同じ内容の質問
  • 広告と受け取られるような投稿

評価を下げると、トップページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

meg_
meg_

2020/09/17 13:43

気になったのは「Set wsAcq = Worksheets(lngSheetIndex)」です。 Set wsAcq = wbAcq.Worksheets(lngSheetIndex) が正しいのではないでしょうか?
icecleam
icecleam

2020/09/17 14:27

以下のように修正し、実行しましたが相変わらず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_
meg_

2020/09/17 14:39

確認ですが「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
icecleam

2020/09/17 14:51 編集

上記のソースにパスを入力してあげたものを実行しただけでした。。 値の入力というのは、今回の画像のような実装の場合、どのようにすれば良いのでしょうか。。 以下のように記載しました。 結果というのはどのようにして確認すれば良いでしょうか。。 すみません、 初心者なもので両者とも初歩的な質問かもしれません。。 '----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい) wsSet.Cells(lngRowsNo, 1) = wsAcq.Cells(1, 1) Debug.Print wsSet.Cells(lngRowsNo, 1).Value Debug.Print wsAcq.Cells(1, 1).Value
meg_
meg_

2020/09/17 14:54

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

2020/09/17 15:00 編集

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

2020/09/17 15:07

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

2020/09/17 15:39 編集

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

2020/09/17 15:39 編集

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

2020/09/17 16:33

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

2020/09/17 22:14 編集

そうです。 まずはファイル名と開発をコピーしたいです。 その場合、転記先のファイルのA1に「ファイル名」、B1に「開発」と記載し、それに該当する列の2以降から、転記元の内容をコピーする ということでしょうか 一晩考えたのですが、列から「〇〇」が先頭にある文字列を捜して取得する 処理の実装が、何度やっても空白セルとなり、うまくできませんでした… 申し訳ありませんが、この場合の具体的な書き方まで教えていただけないでしょうか。 ひとつ分かれば、後もそれを参考にして実装できそうですので…
meg_
meg_

2020/09/17 23:48

例えば下記のように書けます。 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
icecleam

2020/09/18 03:08

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

2020/09/18 04:01

> 開発1.開発2の値を転記 開発A、開発Bではなくてですか? > wsAcq.Cells(1, 1) これですとセル番地を固定してるので同じ値をコピーすることしかできません。 何かVBAをあまり理解されていないようですが、質問のコードはご自身で書かれたものでしょうか?
icecleam
icecleam

2020/09/18 09:03

> 開発A、開発Bではなくてですか? すみません、ただの誤字でした。 wsSet.Cells(lngRowsNo, 1) = wsAcq.Cells(1, 1) の部分をmeg_さんが先ほど記載していただいた内容に置き換えるという意味でした。 すみません、伝わりづらかったですね。 このコードは、以前質問をさせていただいて、その回答としていただいたものです。 すみません、理解できていない部分は正直あります…
meg_
meg_

2020/09/18 09:07

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

2020/09/18 11:47

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

2020/09/18 11:52

ありがとうございます。 今、それで実行してみたら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
icecleam

2020/09/18 11:57 編集

今はピンポイントでB14の値を取ってきていますが あとはこれを担当者の数だけループで回したいです、、 質問内容も編集しましたので、ご迷惑でなければご回答をいただければと思います。。 長時間付き合わせてしまい申し訳ないです
meg_
meg_

2020/09/18 12:04

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

2020/09/18 12:11

上記で試してみたところ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_
meg_

2020/09/18 12:19

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

2020/09/18 12:34

ステップ実行したら、開発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
icecleam

2020/09/18 12:35

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

2020/09/18 13:00

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

2020/09/18 13:20

lngRowsNoのカウントを進めようと思い、以下のようにしたところ、 B1に「開発A」、B2に「開発B」が転記されてしまいました。 「「開発B」は開発Aの担当者(A~H)の数分下の行に転記」 ここの部分で担当者に値が入っている数分、「開発A」を記載するにはどのような処理にすれば良いでしょうか。。 インターネットで調べたら、データのある最後の行位置の変数を以下の式で取れるそうなのですが、今回の場合、転記元の17行目から24行目までの担当者(これはファイルによって可変)の実数値でいうと8を取ってきたいです。。 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_
meg_

2020/09/19 00:58

「開発A」の担当者「A」のセル位置が分かっているとします。(例:Cells(17,2)) ※ 「H」のセルは下記コードで取得できます。 .Cells(17,2).End(xlDown) ※最初の担当者のセル位置はプロジェクト名(開発Aとか)からの相対位置で取得可能です
icecleam
icecleam

2020/09/19 02:16

以下のコードで、開発AをB1〜B8、開発BをB9〜B12に思った通りに転記することができました! meg_さんのアドバイスのおかげです。 ようやく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

まだ回答がついていません

会員登録して回答してみよう

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
87.20%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問

同じタグがついた質問を見る

ファイル

ファイルとは、文字列に基づいた名前又はパスからアクセスすることができる、任意の情報のブロック又は情報を格納するためのリソースです。

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。