[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『転記のループがうまくいかない』(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 >
■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
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行目にも”空白”という文字が入ってしまう)、最終行変数に格納する事で何か出来そうかな…と思い、今検証中です。
matchの考え方、大変勉強になります。ありがとうございました!
(Try) 2021/11/27(土) 13:17
■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
ちなみに、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
このようにすることによって、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.