[[20211127095527]] 『転記のループがうまくいかない』(Try) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『転記のループがうまくいかない』(Try)

初めまして。いつもこちらで拝見させて頂いています。教えて下さい。

1. マクロファイルのSheet1に、転記したい項目の見出しが書いてあります。

   A列
 1 aa
 2 ee
 3 cc
 4 空白
 5 ff
 6 gg

2. From.xlsxファイルのSheet1に下記のようなリストがあります。

    A    B    C   D     E    F     G
 1  bb	 j   cc	  dd	ee   空白  gg
 2  2	 1   3	  2	4	   1
 3  2	 1   1	  5	2	   1
 4  3	 1   5	  6	3	   2
 5  5	 1   2	  2	1	   3
 6  2	 1   3	  1	1	   4

3. To.xlsxファイルのSheet1に下記のような見出しだけのものがあります(この順番は1.の順番と同じです。(縦横の違いのみ)

    A    B    C   D     E    F     
 1  aa	 ee   cc  空白  ff   gg

やりたい事は、To.xlsxにFrom.xlsxの内容を列ごと転記したいのですが、
デバックでみると正しく取得しているように思える?のですが、
貼り付けると、項目に一致した列が貼りつきません。
(aaにeeのデータ、eeにccのデータ、空白にggのデータが貼りついてしまう)

どこがおかしいか分かりますでしょうか。

また、もう一点お聞きしたくて、最終的には、From.xlsxデータが何個もあるとして、From2.xlsx, From3.xlsx…どんどん転記先ファイルに合体していきたいのですが、その場合、一気にいく方法はありますか?
マクロコードをコピーして、
Set wb_From = Workbooks.Open(ThisWorkbook.path & "\From.xlsx")
の部分の参照先を変えれば出来るのでしょうが、いいやり方があれば併せて教えて下さい。

Sub try()

Dim wb As Workbook
Dim wb_From As Workbook
Dim wb_To As Workbook

Set wb = ThisWorkbook
Set wb_From = Workbooks.Open(ThisWorkbook.path & "\From.xlsx")
Set wb_To = Workbooks.Open(ThisWorkbook.path & "\To.xlsx")

Dim Column_From As Long 'コピー元列数
Dim Row_From As Long 'コピー元行数
Dim Row_Temp As Long 'コピー項目リスト行数
Dim To_index As Long 'コピー先列インデックス
Dim Row_To As Long 'コピー先行数

Column_From = wb_From.Sheets("sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
Row_From = wb_From.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Row_Temp = wb.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
To_index = 1
Row_To = wb_To.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row

For Row_Temp = 1 To Row_Temp

    For Column_From = 1 To Column_From
        If wb_From.Sheets("sheet1").Cells(1, Column_From).Value = wb.Sheets("sheet1").Cells(Row_Temp, 1).Value Then
            Range(wb_From.Sheets("sheet1").Cells(2, Column_From), wb_From.Sheets("sheet1").Cells(Row_From, Column_From)).Copy wb_To.Sheets("sheet1").Cells(Row_To + 1, To_index)
            To_index = To_index + 1
        End If
    Next
Next

MsgBox "outputファイルを確認して、次のファイルの合体に進んで下さい"
End Sub

< 使用 Excel:Excel2010、使用 OS:unknown >


■1
>やりたい事は、To.xlsxにFrom.xlsxの内容を列ごと転記したい
アプローチを変えてよければ、フィルタオプションの利用を考えてみてはどうでしょうか?
(空白列があるのがネックかもしれませんが)

■2
>どんどん転記先ファイルに合体していきたいのですが、
元データのリストを用意しておく、1つのフォルダにあるファイルをループ処理で巡回するなどの方法で可能だとおもいます。

■3
>どこがおかしいか
ざっと見ですが、列の並び順が違うのですから、出力先の列に合わせて、データ元の列を逐一調べないとダメじゃないですか?

(もこな2) 2021/11/27(土) 11:06


 思うように動かなければ他の回答をお待ちください。
 Sub try2()
    Dim wb As Workbook
    Dim wb_From As Workbook
    Dim wb_To As Workbook
    Dim i As Long, myC As Variant

    Set wb = ThisWorkbook
    Set wb_From = Workbooks.Open(ThisWorkbook.Path & "\From.xlsx")
    Set wb_To = Workbooks.Open(ThisWorkbook.Path & "\To.xlsx")
    With wb.Worksheets("Sheet1")
        For i = 1 To .Cells(Rows.Count, "A").End(xlUp).Row
            If .Cells(i, 1).Value <> "" Then
                myC = Application.Match(.Cells(i, 1).Value, wb_From.Worksheets("Sheet1").Rows(1), 0)
                If IsError(myC) Then
                    MsgBox .Cells(i, 1).Value & " が " & wb_From.Name & "の1行目に見つかりません。", vbExclamation
                Else
                    With wb_From.Worksheets("Sheet1")
                        .Range(.Cells(2, myC), .Cells(Rows.Count, myC).End(xlUp)).Copy _
                            wb_To.Worksheets("Sheet1").Cells(Rows.Count, i).End(xlUp).Offset(1)
                    End With
                End If
            End If
        Next
    End With
    MsgBox "outputファイルを確認して、次のファイルの合体に進んで下さい"
 End Sub

(ピンク) 2021/11/27(土) 11:37


既に回答があるようですが投稿しておきます。
■4
「■3」のアプローチをコード化するとこんな感じです。興味があればステップ実行して研究してみてください。
    Sub 研究用()
        Dim srcSH As Worksheet
        Dim dstSH As Worksheet
        Dim 出力列 As Long
        Dim データ列 As Variant
        Dim Row_From As Long

        Stop 'ブレークポイントの代わり

        Set srcSH = Workbooks.Open(ThisWorkbook.Path & "\From.xlsx").Worksheets("sheet1")
        Set dstSH = Workbooks.Open(ThisWorkbook.Path & "\To.xlsx").Worksheets("sheet1")
        Row_From = srcSH.Cells(srcSH.Rows.Count, 1).End(xlUp).Row

        With dstSH
            For 出力列 = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
                If .Cells(1, 出力列).Value <> "" Then
                    '▼対応する列を調べる
                    データ列 = Application.Match(.Cells(1, 出力列).Value, srcSH.Rows(1), 0)

                    '▼(念のため)対応する列が見つかった時だけ処理する
                    If Not IsError(データ列) Then
                        Intersect(srcSH.Rows("2:" & Row_From), srcSH.Columns(データ列)).Copy Destination:=.Cells(.Rows.Count, 出力列).End(xlUp).Offset(1)
                    End If
                End If
            Next 出力列
        End With
    End Sub

※なお、ステップ実行という言葉を聞いたことがなければ↓を読んでみてください。

 【ステップ実行】
https://www.239-programing.com/excel-vba/basic/basic023.html
http://plus1excel.web.fc2.com/learning/l301/t405.html

 【ブレークポイント】
https://www.239-programing.com/excel-vba/basic/basic022.html
https://www.tipsfound.com/vba/01010

また、以下も知っておいて損は無いと思います。

 【イミディエイトウィンドウ】
https://www.239-programing.com/excel-vba/basic/basic024.html
https://excel-ubara.com/excelvba1/EXCELVBA486.html

 【ローカルウィンドウ】
https://excel-ubara.com/excelvba4/EXCEL266.html
http://excelvba.pc-users.net/fol8/8_2.html

(もこな2) 2021/11/27(土) 11:44


もこな2様
ありがとうございます。
■1フィルタオプション
ありがとうございます、今調べてTryしてみました。シンプルにいきそうですね。ただ、実際のデータは条件書式が入っていたり、セルが結合したり…色々で、
今試しにやってみたらちょっと動きが不安定な気がするので、今回は■3で教えて頂いたmatch形式でいきたいと思います。
■2
For Each wb in Workbooks〜のようなイメージでしょうか。まだやったことありませんが、Tryしてみます。
■3
コードのご提示までありがとうございます。無事再現できました。
項目名が一致するか確認した後、処理をするのですね。私のだと、ステップが足りませんでしたね。。
ステップ実行等のリンクもありがとうございます。勉強し始めたばかりなので、こういう情報は大変助かります。

ピンク様
ありがとうございます。
空白列の部分だけがうまくいかなかったのですが(貼り付け先の2行目にも”空白”という文字が入ってしまう)、最終行変数に格納する事で何か出来そうかな…と思い、今検証中です。
matchの考え方、大変勉強になります。ありがとうございました!
(Try) 2021/11/27(土) 13:17


■5
>For Each wb in Workbooks〜のようなイメージでしょうか。
ん〜今回はちょっと違いますね。

■5-1
例えば【リストを用意しておく】ならば、たとえばリストという名前のシートに↓のようにしておき

    __A___
 1  ブック名
 2  001.xlsx
 3  002.xlsx
 4  002.xlsx
 5  003.xlsx
 6  004.xlsx

↓のコードを実行するようなイメージでしょうか

    Sub 実験01()
        Dim srcSH As Worksheet
        Dim i As Long

        Stop

        With ThisWorkbook.Worksheets("リスト")
            For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
                Set srcSH = Workbooks.Open(ThisWorkbook.Path & "\" & .Cells(i, "A").Value).Worksheets("sheet1")
                    '〜〜処理〜〜〜
                srcSH.Parent.Close False
            Next i
        End With
    End Sub

■5-2
また、【フォルダにあるファイルをループ処理で巡回する】ならこんな感じですね。

    Sub 実験02()
        Dim srcSH As Worksheet
        Dim ファイル名 As String

        Stop

        ファイル名 = Dir(ThisWorkbook.Path & "*.xlsx")
        Do Until ファイル名 = ""
            Select Case ファイル名
                Case ThisWorkbook.Name, "To.xlsx"
                    '自ブックと、出力先のブックは除外

                Case Else
                    Set srcSH = Workbooks.Open(ThisWorkbook.Path & "\" & ファイル名).Worksheets("sheet1")
                                '〜〜処理〜〜〜
                    srcSH.Parent.Close False

            End Select

            ファイル名 = Dir() '←次のファイルを探す
        Loop
    End Sub

(もこな2) 2021/11/27(土) 14:46


 >空白列の部分だけがうまくいかなかったのですが
 >(貼り付け先の2行目にも”空白”という文字が入ってしまう)、
    A列
  1 aa
  2 ee
  3 cc
  4 空白 ← これは文字で"空白"が入っているのですか?
  5 ff
  6 gg

  If .Cells(i, 1).Value <> "" Then

         ↓ に修正してください。

  If .Cells(i, 1).Value <> "空白" Then

(ピンク) 2021/11/27(土) 15:04


もこな様
ありがとうございます!!
このようなケース(複数ファイルに対して同じような作業を繰り返す)を実施する事が多いので、
教えて頂いたものをマスターして、今後色々活用していきたいと思います。
ご丁寧なご説明、ありがとうございました。

ピンク様
ありがとうございます!!
分かりにくくてすみませんでした。そうです、空白列を表として扱いたくて、
あえて項目名に"空白"という見出しをつけたらいいのではないか…と思い、
今回文字で入力していました。
そこを直せば良かったのですね…、、あの後色々やっても分からずでしたが、すっきりしました。
大変ありがとうございます!

(try) 2021/11/27(土) 16:30


もこな様
度々すみません、教えて頂いたものを合体して、かつ変数名等は自分流に変えてしまいましたが、
下記で複数のWorkbookでも動くようにTryしているのですが、1つ目のファイルは正しく貼りつくのですが、
二つ目のファイルで、ファイルは開くのですが転記がされません。
なぜだか分かりますでしょうか。。

ちなみに、1つ目のファイルで例えば項目名aaが転記先にはあるのに転記元にはない場合、かつ2つ目のファイルで項目名aaが転記元・転記先に両方ありmatchして貼り付け対象となる場合は、上に詰めて貼りついてしまうため、そこを回避したく、下記だけは変更してしまったのですが、それが原因ではないようなのですが。。

今回変更した部分。LsastRowで転記先の貼り付けスタート位置を把握。
LastRow = 先SH.Cells(先SH.Rows.Count, 3).End(xlUp).Row '←3列目:項目名ccはどのファイルにも存在するとしてこうしています。
Intersect(元SH.Rows("2:" & 出力行), 元SH.Columns(match列)).Copy Destination:=.Cells(LastRow, 出力列).End(xlUp).Offset(1)

単独では正しく動くのに、複数ファイルで対応しようとすると、2つ目以降のファイルの情報が転記されません。
もこな様に教えて頂いたコードの、'〜〜処理〜〜〜 の部分に、最初に教えて頂いたコードを入れているイメージなのですが…。

    Sub 実験01()
        Dim 元SH As Worksheet
        Dim i As Long

        With ThisWorkbook.Worksheets("sheet1")
            For i = 1 To .Cells(.Rows.Count, "B").End(xlUp).Row '←B列1行目〜ファイル名を書き込みました。
                Set 元SH = Workbooks.Open(ThisWorkbook.path & "\" & .Cells(i, "B").Value).Worksheets("sheet1")

        Dim 先SH As Worksheet
        Dim 出力列 As Long
        Dim match列 As Variant
        Dim 出力行 As Long

        Set 先SH = Workbooks.Open(ThisWorkbook.path & "\To.xlsx").Worksheets("sheet1")
        出力行 = 元SH.Cells(元SH.Rows.Count, 1).End(xlUp).Row

        With 先SH
            For 出力列 = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
                If .Cells(1, 出力列).Value <> "" Then
                    '▼対応する列を調べる
                    match列 = Application.Match(.Cells(1, 出力列).Value, 元SH.Rows(1), 0)
                    '▼(念のため)対応する列が見つかった時だけ処理する
                    If Not IsError(match列) Then
                    Dim LastRow As Long
                    LastRow = 先SH.Cells(先SH.Rows.Count, 3).End(xlUp).Row
                        Intersect(元SH.Rows("2:" & 出力行), 元SH.Columns(match列)).Copy Destination:=.Cells(LastRow, 出力列).End(xlUp).Offset(1)
                    End If
                End If
            Next 出力列
        End With
                元SH.Parent.Close False
            Next i
        End With
    End Sub

すみません、何かわかりましたら教えて頂けますと幸いです。
(Try) 2021/11/27(土) 19:19


連投すみません、原因が分かりました。
下記を、
Intersect(元SH.Rows("2:" & 出力行), 元SH.Columns(match列)).Copy Destination:=.Cells(LastRow, 出力列).End(xlUp).Offset(1)

このようにすることによって、2ファイル目以降も正しく貼りつきました。
Intersect(元SH.Rows("2:" & 出力行), 元SH.Columns(match列)).Copy Destination:=.Cells(LastRow + 1, 出力列)

また、上の投稿ではLastRowの変数を設定する位置が悪かったのですが、
下記のコードとする事で、正しい書き方であるのかはまだ分かりませんが、やりたい事は再現できました。

    Sub 実験01()
        Dim 元SH As Worksheet
        Dim i As Long

        Dim 先SH As Worksheet
        Set 先SH = Workbooks.Open(ThisWorkbook.path & "\To.xlsx").Worksheets("sheet1")

        With ThisWorkbook.Worksheets("sheet1")
            For i = 1 To .Cells(.Rows.Count, "B").End(xlUp).Row  'B列1行目〜元データのファイル名を入力する。
                Set 元SH = Workbooks.Open(ThisWorkbook.path & "\" & .Cells(i, "B").Value).Worksheets("sheet1")

        Dim 出力列 As Long
        Dim match列 As Variant
        Dim 出力行 As Long
        Dim LastRow As Long

        LastRow = 先SH.Cells(先SH.Rows.Count, 3).End(xlUp).Row  '←必ず全てのファイルに存在する項目名の列で最終行を取得
        出力行 = 元SH.Cells(元SH.Rows.Count, 1).End(xlUp).Row

            With 先SH
                For 出力列 = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
                    If .Cells(1, 出力列).Value <> "" Then
                        '▼対応する列を調べる
                        match列 = Application.Match(.Cells(1, 出力列).Value, 元SH.Rows(1), 0)
                        '▼(念のため)対応する列が見つかった時だけ処理する
                        If Not IsError(match列) Then

                            Intersect(元SH.Rows("2:" & 出力行), 元SH.Columns(match列)).Copy Destination:=.Cells(LastRow + 1, 出力列)
                        End If
                    End If
                Next 出力列
            End With

            元SH.Parent.Close False

            Next i
        End With

MsgBox "outputファイルを確認して、上書き保存して下さい"
End Sub

ここで色々教えて頂いた事を、今一度整理してみたいと思います。。
大変ありがとうございました。
(Try) 2021/11/27(土) 20:42


なんか見たことあるな〜。

(チンチクリン) 2021/11/28(日) 23:26


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.