『2枚のシートから別シートに置き換え』（教えてください）
下記シートが2枚ありまして
シート１
A列 B列
ABC-123 みかん123
ABC-124 みかん123
ABC-125 みかん123
ABC-126 みかん123
ABC-127 みかん123
ABC-128 りんご123
ABC-129 りんご123
ABC-130 りんご123
ABC-131 りんご123
ABC-132 りんご123
シート２
A列 B列 C列 D列 E列 F列 G列
みかん123 1 ブラック B1 1 AAA A1
みかん123 1 ブラック B1 2 BBB A2
みかん123 1 ブラック B1 3 CCC A3
みかん123 2 ホワイト B2 1 DDD A1
みかん123 2 ホワイト B2 2 EEE A2
みかん123 2 ホワイト B2 3 FFF A3
りんご123 1 ブラック B1 1 GGG A1
りんご123 1 ブラック B1 2 HHH A2
りんご123 1 ブラック B1 3 III A3
りんご123 1 ブラック B1 4 JJJ A4
りんご123 1 ブラック B1 5 KKK A5
りんご123 1 ブラック B1 6 LLL A6
りんご123 1 ブラック B1 7 MMM A7
りんご123 1 ブラック B1 8 NNN A8
りんご123 1 ブラック B1 9 OOO A9
りんご123 2 ホワイト B2 1 PPP A1
りんご123 2 ホワイト B2 2 QQQ A2
りんご123 2 ホワイト B2 3 RRR A3
りんご123 2 ホワイト B2 4 SSS A4
りんご123 2 ホワイト B2 5 TTT A5
りんご123 2 ホワイト B2 6 UUU A6
りんご123 2 ホワイト B2 7 VVV A7
りんご123 2 ホワイト B2 8 WWW A8
りんご123 2 ホワイト B2 9 XXX A9
シート１のB列がシート２のA列と同じ場合に新しいシートに下記の様に置き換えたいのですが可能でしょうか？
A列 B列 C列 D列 E列 F列 G列
ABC-123 1 ブラック B1 1 AAA A1
ABC-123 1 ブラック B1 2 BBB A2
ABC-123 1 ブラック B1 3 CCC A3
ABC-123 2 ホワイト B2 1 DDD A1
ABC-123 2 ホワイト B2 2 EEE A2
ABC-123 2 ホワイト B2 3 FFF A3
＜ 使用 Excel：Microsoft365、使用 OS：Windows10 ＞
＞シート１のB列の値がシート２のA列の値と一致してたら
一致するものが無かったら、その行は抜かすのですか？
みかん123は、シート1に5個あるんですが、 トップにあるA列のデータを出力するんですね？
B列の処理については、単なる記入漏れですね？
（半平太） 2024/04/14(日) 07:22:09
（IT） 2024/04/14(日) 08:40:49
その例だと、シート３は、 5×6 + 5 ×18 = 120行 になるということですか?
（xyz） 2024/04/15(月) 09:50:51
一致するものが無かったら、その行は抜かすのですか？→無い事が判る方がいいです。
みかん123は、シート1に5個あるんですが、
トップにあるA列のデータを出力するんですね？→A列からG列までを出力したいです。
B列の処理については、単なる記入漏れですね？→B列は空白セルになります。
（教えてください） 2024/04/15(月) 19:55:44
ABC-123 1 ブラック B1 1 AAA A1
ABC-123 1 ブラック B1 2 BBB A2
ABC-123 1 ブラック B1 3 CCC A3
ABC-123 2 ホワイト B2 1 DDD A1
ABC-123 2 ホワイト B2 2 EEE A2
ABC-123 2 ホワイト B2 3 FFF A3
ABC-124 1 ブラック B1 1 AAA A1
ABC-124 1 ブラック B1 2 BBB A2
ABC-124 1 ブラック B1 3 CCC A3
ABC-124 2 ホワイト B2 1 DDD A1
ABC-124 2 ホワイト B2 2 EEE A2
ABC-124 2 ホワイト B2 3 FFF A3
ABC-125 1 ブラック B1 1 AAA A1
ABC-125 1 ブラック B1 2 BBB A2
ABC-125 1 ブラック B1 3 CCC A3
ABC-125 2 ホワイト B2 1 DDD A1
ABC-125 2 ホワイト B2 2 EEE A2
ABC-125 2 ホワイト B2 3 FFF A3
（教えてください） 2024/04/15(月) 19:58:28
これは、PowerQueryで"左外部結合"を使ってマージするのが、一番簡単だと思います。 また、ワークシート関数だけで書けるのかもしれないですが、私には365ベースの環境がないので、 マクロを利用する案を提示しておきます。
・下記のマクロを標準モジュールにコピーペイストしてください。
【留意点】 ・Sheet1,Sheet2,Sheet3というシート名をそちらの状況に合わせて、コードを修正して下さい。（■の部分です） ・Sheet1とSheet2の一行目には見出し行を追加して下さい（【重要】) ・Sheet3は空白シートでOKです。 ・マクロ"test"を実行して下さい。結果がSheet3に書き込まれるはずです。 （マッチしないデータがあれば、MsgBoxを表示してマクロを終了します）
【マクロコード】
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim dic As Object, dicRng As Object
Dim rng As Range, key As Variant
Dim cnt1&, cnt2&, s1$, s2$, k&, lastRow&
Set ws1 = Worksheets("Sheet1") '■シート名を適宜修正して下さい
Set ws2 = Worksheets("Sheet2") '■シート名を適宜修正して下さい
Set ws3 = Worksheets("Sheet3") '■シート名を適宜修正して下さい
'■また、Sheet1とSheet2の一行目に見出し行を挿入しておいて下さい。
'Sheet1のB列を重複除きで取得
Set dic = CreateObject("Scripting.Dictionary")
For k = 2 To ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row
dic(ws1.Cells(k, "B").Value) = Empty
Next
'Sheet2の対応する範囲を辞書に取得
Set dicRng = CreateObject("Scripting.Dictionary")
For Each key In dic
ws2.Range("A1").AutoFilter Field:=1, Criteria1:=key
Set rng = ws2.AutoFilter.Range
If Intersect(rng, ws2.Columns("A")).SpecialCells(xlCellTypeVisible).Count = 1 Then
MsgBox "「" & key & "」 に対応するシート2のデータがありません。終了します。"
Exit Sub
End If
Set rng = Intersect(rng, rng.Offset(1), rng.Offset(0, 1))
Set dicRng(key) = rng.SpecialCells(xlCellTypeVisible)
Next
ws2.AutoFilterMode = False
'組み合わせをws3に書き込む
With ws1
For k = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
s1 = .Cells(k, "A")
s2 = .Cells(k, "B")
If ws3.[A1] = "" Then
lastRow = 0
Else
lastRow = ws3.Cells(Rows.Count, "A").End(xlUp).Row
End If
Set rng = dicRng(s2)
cnt1 = rng.Rows.Count
cnt2 = rng.Columns.Count
ws3.Cells(lastRow + 1, "A").Resize(cnt1, 1) = s1
ws3.Cells(lastRow + 1, "B").Resize(cnt1, cnt2) = rng.Value
Next
End With
End Sub
（xyz） 2024/04/16(火) 10:18:51
ご回答ありがとうございます。
丁寧な返信本当に感謝いたします。
マクロで実行を行ったのですが、
Sheet1,Sheet2,Sheet3のままで実行しております。
Sheet1とSheet2の一行目には見出し行を追加して下さい→空白行を1行ずつ追加しました。
実行時エラー91
オブジェクト変数またはwith ブロック変数が設定されておりません。
と出ます。
デバックを開くと
Set dicRng(key) = rng.SpecialCells(xlCellTypeVisible)
の部分が黄色になっています。
マクロの知識が無く、本当に申し訳ないのですが、
ご教授いただけるとありがたいです。
よろしくお願いいたします。
（教えてください） 2024/04/17(水) 14:56:05
よろしくお願いいたします。
（教えてください） 2024/04/17(水) 14:57:44
Sub main()
'Sheet1とSheet2からSheet3に書き出す
Dim c As Range, c1 As Range, r As Range, r1 As Range
Sheets("Sheet3").Cells.ClearContents
For Each c In Sheets("Sheet1").Range("B:B").SpecialCells(2)
Set r = Nothing
For Each c1 In Sheets("Sheet2").Range("A:A").SpecialCells(2)
If c.Value = c1.Value Then
If r Is Nothing Then
Set r = c1
Else
Set r = Union(c1, r)
End If
End If
Next c1
If Not r Is Nothing Then
Set r1 = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(r.Rows.Count)
r.Resize(, 7).Copy r1
r1.Value = c.Offset(, -1).Value
End If
Next c
End Sub
（mm） 2024/04/17(水) 15:37:01
外出中なので詳細はわかりませんが、 見出しになんらかの見出しを入れてみてください。(明確に書くべきでした） itm1,itm2,・・・のような機械的なもので結構です。
事象は変わらないでしょうか。
# 私の手元では正常に動作しているのを確認して投稿しています。 # たぶん想定していないデータがあるのかもしれません。 （xyz） 2024/04/17(水) 15:43:49
えー、それからSheet2のA列は同一のキーが固まっていることを条件にしています。 そうでなければ、A列をキーにしてソートしてからトライしてみてください。
（xyz） 2024/04/17(水) 15:49:59
修正は特に要らないと思います。
それと別件で、前に実行した結果が残っているとまずい場合には、 ws3をいったんクリアーしたほうがよいかもしれません。
'組み合わせをws3に書き込む ws3.UsedRange.ClearContents '← これを追加してください。 With ws1
（xyz） 2024/04/17(水) 18:57:04
sheet2がH列までありまして、
Sheet3にsheet2のH列も書き出ししたいです。
（教えてください） 2024/04/18(木) 15:18:17
よろしくお願いいたします。
（教えてください） 2024/04/18(木) 15:19:15
こちらでは再現しないです。H列まで対象になります。 たぶん、こちらの想定していないデータになっているのではないと想像します。
(1)Sheet2のデータのG列は空白です、とかいうことはないですね。
(2)Sheet2のA1:H2まではすべて入力がされているんですね？こちらにコピーペイストしてもらえますか?
(3)以下の修正をして試して貰えますか？
| 'Sheet2の対応する範囲を辞書に取得
| Set dicRng = CreateObject("Scripting.Dictionary")
| For Each key In dic
| ws2.Range("A1").AutoFilter Field:=1, Criteria1:=key
の最後の行を
ws2.Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=key
に変更して再実行してみて下さい。
（xyz） 2024/04/18(木) 15:47:39
Sub main()
'Sheet1とSheet2からSheet3に書き出す
Dim c As Range, c1 As Range, r As Range, r1 As Range
Sheets("Sheet3").Cells.ClearContents
For Each c In Sheets("Sheet1").Range("B:B").SpecialCells(2)
Set r = Nothing
For Each c1 In Sheets("Sheet2").Range("A:A").SpecialCells(2)
If c.Value = c1.Value Then
If r Is Nothing Then
Set r = c1
Else
Set r = Union(c1, r)
End If
End If
Next c1
If Not r Is Nothing Then
Set r1 = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(r.Rows.Count)
r.Resize(, 7).Copy r1
r1.Value = c.Offset(, -1).Value
End If
Next c
End Sub
（教えてください） 2024/04/18(木) 18:07:21
＞Sheet3にsheet2のH列も書き出ししたいです。
１．それだけの話なら、以下の変更でいいでしょう。
＞ r.Resize(, 7).Copy r1
↓
r.Resize(, 8).Copy r1’１列増加させる。
２．けど、こう言う仕様はどうなったんですか？ ＞B列の処理については、単なる記入漏れですね？→B列は空白セルになります。 ＞一致するものが無かったら、その行は抜かすのですか？→無い事が判る方がいいです。
提示されたSheet2のサンプルが多い割には、仕様の明確化に役立ってないです。 以下の簡単なサンプルだったら Sheet3がどうなるべきなのか示して貰えるとクリアなのですがね・・
<Sheet1 サンプル> 行 ___A___ ____B____ 1 ABC-123 みかん123 2 ABC-124 みかん123 3 ABC-128 りんご123 4 ABC-129 りんご123 5 ABC-130 りんご123 6 ABC-888 ぶどう777
<Sheet2 サンプル 行 ____A____ _B_ _____C_____ _D_ _E_ _F_ _G_ _H_ 1 みかん123 1 ブラック B1 1 AAA A1 H1 2 みかん123 2 ブラック02 B2 2 BBB A2 H2 3 梨356 3 ブラック03 B3 2 BBB A2 H2 4 りんご123 4 ホワイト B4 5 KKK A5 H11 5 りんご123 5 ブラック B5 6 LLL A6 H12 6 りんご123 6 グリーン B6 7 MMM A7 H13
３．あと、本当に1行目に項目タイトルって無いんですか？
（半平太） 2024/04/19(金) 17:42:16
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.