『2枚のシートから別シートに置き換え』(教えてください)
下記シートが2枚ありまして
シート1
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
シート2
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
シート1のB列がシート2の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 >
>シート1のB列の値がシート2のA列の値と一致してたら
一致するものが無かったら、その行は抜かすのですか?
みかん123は、シート1に5個あるんですが、 トップにあるA列のデータを出力するんですね?
B列の処理については、単なる記入漏れですね?
(半平太) 2024/04/14(日) 07:22:09
(IT) 2024/04/14(日) 08:40:49
その例だと、シート3は、 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列も書き出ししたいです。
1.それだけの話なら、以下の変更でいいでしょう。
> r.Resize(, 7).Copy r1 ↓ r.Resize(, 8).Copy r1’1列増加させる。
2.けど、こう言う仕様はどうなったんですか? >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
3.あと、本当に1行目に項目タイトルって無いんですか?
(半平太) 2024/04/19(金) 17:42:16
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.