EXCEL 表の整理 VBA

1シート目に
A　　　　 B　　　　C　　　　 D
果物
りんご
みかん
なし

2シート目に
A　　　　 B　　　　 C　　　　 D
果物　　地域　　該当有無
りんご　(4青森)　該当なし
みかん　(3静岡)　該当なし
なし　　(4栃木)　該当なし
りんご　(2新潟)　該当なし
みかん　(11愛媛)　該当あり
なし　　(2群馬)　該当なし
りんご　(8埼玉)　該当あり
みかん　(13東京)　該当なし
りんご　(6千葉)　該当なし


要望
１シート目に２シート目の該当なしの果物のみ地域を
各果物の行に１マス毎入力されるようにしたい場合どのようなコードにすれば可能でしょうか
お教えください。また数字は若い順に並び替え配置できますでしょうか。
なお、各果物の地域番号は重複しません、地域を横に張り付ける個数は最大20程になります
果物は1シート目は4行目から, 2シート目は3行目から入力されております。

1シート目　結果
A　　　　 B　　　　 C　　　　 D
果物
りんご　(2新潟)　(4青森)　(6千葉)　
みかん　(3静岡)　(13東京)
なし　　(2群馬)　(4栃木)

よろしくお願いいたします

No.2 ベストアンサー 回答者： fujillin 回答日時： 2021/12/22 16:48

こんにちは

＞数字は若い順に並び替え配置できますでしょうか。
この部分が、少々面倒ですね。

ですので、エクセルのシートの機能を利用する方法での回答にしてみました。
・1シート目、2シート目というのはSheet1、Sheet2と仮定しています
　（異なる場合は、シート名又は番号を変えてください）
・1シート目は4行から、2シート目は3行から実データが始まるものと仮定しています
　（タイトルはその1行上と考えました）
・1シート目は作業用に利用していますので、一旦、4行目以降を消去します
・1シート目の果物名はマクロで抽出していますので、記入不要です
　（順序は、2シート目での出現順になります）
・2シート目のデータには空白行は無いものと仮定しています
　（空白行がある場合は、空白行も抽出されますのでご注意）
・B列の数字は、2文字目から始まるものとし、英数半角の数字であると仮定しています
　（数字のないものがある場合、順序は最後になります）

以下、ご参考までに。
Sub Q12725439()
Dim reg, sht As Worksheet
Dim r As Range, c As Range
Dim n As Long, m As Long
Const sh1 = "Sheet1"
Const sh2 = "Sheet2"

Set sht = Worksheets(sh2)
Set reg = CreateObject("VBScript.RegExp")
reg.Pattern = "(.)(\d*)(.*)"

With Worksheets(sh1)
.AutoFilterMode = False
.Range("A4").Resize(Rows.Count - 3, 20).ClearContents
n = sht.Cells(Rows.Count, 1).End(xlUp).Row - 1
If n < 2 Then Exit Sub

Application.ScreenUpdating = False
.Range("A4").Resize(n).Value = sht.Range("A3").Resize(n).Value
.Range("A4").Resize(n).RemoveDuplicates Columns:=1, Header:=xlNo
m = .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(m + 1, 1).Resize(n, 3).Value = sht.Range("A2").Resize(n, 3).Value

Set r = .Cells(m + 1, 1).Resize(n, 4)
For Each c In r.Columns(1).Cells
c.Offset(, 3).Value = reg.Replace(c.Offset(, 1).Text, "$2")
Next c
r.Sort Key1:=r.Cells(1, 1), key2:=r.Cells(1, 4), Header:=xlYes
For Each c In .Range("A4").Resize(m - 3)
r.AutoFilter field:=3, Criteria1:="該当なし"
r.AutoFilter field:=1, Criteria1:=c.Text
r.Columns(2).Offset(1).Copy
c.Offset(, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
r.AutoFilter
Next c

r.ClearContents
Application.ScreenUpdating = True
End With
End Sub

この回答へのお礼

正確な動作で　全コードを書いていただきありがとうございます。
1番目に書かれた方の仰っているように次回からなるべく自力でコードを書いていくようにします。
この度はありがとうございます

お礼日時：2021/12/23 00:18

No.1 回答者： mygoonickname 回答日時： 2021/12/22 09:17

おはようございます。

個人的な意見になりますが、ここはコードを依頼する場所ではないので、
質問者さん自身がコードを作成される場所だと、私は思っています。
ある程度、お力になりたいとは思いますが、プログラムを書くのを全て
教えるのも大変なので、マクロの記録である程度作って、それを修正する
形が良いかと思います。

先ずは、マクロの記録で、下記の操作をして、そのコードをアップして
下さい。

2シート目を新しいブックにコピーする。　新しいブック上で、
りんご　(4青森)　該当なし　の行のD列は、D2になるでしょうか？
D2なら下記関数を入れる。
=LOOKUP(1000,MID(B2,2,COLUMN(1:1))*1)
D2の式を、データのある最後の行までコピーする(数字だけが出るはず)
A1～D列の末尾まで範囲を選択し、データの並べ替え
１，該当有無、降順
２，果物、昇順
３，D列、昇順

記録終了して、先ずは、マクロコードをアップして下さい。

上記操作で、データが並んだ状態（３列は変わりませんが）になると
思います。　それを、１シートに書き込めば良いかと。

＊＊＊下記、補足記事になります。＊＊＊

マクロの記録
https://excel-ubara.com/excelvba1/EXCELVBA303.html

関数、LOOKUP～　の説明は下記記事を参照。　それを改変したもの。
https://se.ekaki-j.com/excel-lookup-right-column/